[BACK]Return to lonnet.pm CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom / lonnet / perl

Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.982 and 1.986

version 1.982, 2009/01/02 22:45:43 version 1.986, 2009/02/10 11:15:16
Line 74  use strict; Line 74  use strict;
 use LWP::UserAgent();  use LWP::UserAgent();
 use HTTP::Date;  use HTTP::Date;
 use Image::Magick;  use Image::Magick;
   use IO::Socket;
   
 # use Date::Parse;  # use Date::Parse;
 use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir  use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
Line 150  sub logthis { Line 151  sub logthis {
     my $now=time;      my $now=time;
     my $local=localtime($now);      my $local=localtime($now);
     if (open(my $fh,">>$execdir/logs/lonnet.log")) {      if (open(my $fh,">>$execdir/logs/lonnet.log")) {
  print $fh "$local ($$): $message\n";   my $logstring = $local. " ($$): ".$message."\n"; # Keep any \'s in string.
    print $fh $logstring;
  close($fh);   close($fh);
     }      }
     return 1;      return 1;
Line 181  sub create_connection { Line 183  sub create_connection {
     return 0;      return 0;
 }  }
   
   sub get_server_timezone {
       my ($cnum,$cdom) = @_;
       my $home=&homeserver($cnum,$cdom);
       if ($home ne 'no_host') {
           my $cachetime = 24*3600;
           my ($timezone,$cached)=&is_cached_new('servertimezone',$home);
           if (defined($cached)) {
               return $timezone;
           } else {
               my $timezone = &reply('servertimezone',$home);
               return &do_cache_new('servertimezone',$home,$timezone,$cachetime);
           }
       }
   }
   
 # -------------------------------------------------- Non-critical communication  # -------------------------------------------------- Non-critical communication
 sub subreply {  sub subreply {
Line 1245  sub get_domain_defaults { Line 1261  sub get_domain_defaults {
         $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};          $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};
         $domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'};          $domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'};
         $domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'};          $domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'};
         $domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'}          $domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'};
     } else {      } else {
         $domdefaults{'lang_def'} = &domain($domain,'lang_def');          $domdefaults{'lang_def'} = &domain($domain,'lang_def');
         $domdefaults{'auth_def'} = &domain($domain,'auth_def');          $domdefaults{'auth_def'} = &domain($domain,'auth_def');
Line 1264  sub get_domain_defaults { Line 1280  sub get_domain_defaults {
             }              }
         }          }
     }      }
       if (ref($domconfig{'requestcourses'}) eq 'HASH') {
           foreach my $item ('official','unofficial') {
               $domdefaults{$item} = $domconfig{'requestcourses'}{$item};
           }
       }
     &Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults,      &Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults,
                                   $cachetime);                                    $cachetime);
     return %domdefaults;      return %domdefaults;
Line 2015  sub clean_filename { Line 2036  sub clean_filename {
     $fname=~s/\.(\d+)(?=\.)/_$1/g;      $fname=~s/\.(\d+)(?=\.)/_$1/g;
     return $fname;      return $fname;
 }  }
   #This Function check if a Image max 400px width and height 500px. If not then scale the image down
   sub resizeImage {
    my($img_url) = @_;
    my $ima = Image::Magick->new;                       
           $ima->Read($img_url);
    if($ima->Get('width') > 400)
    {
    my $factor = $ima->Get('width')/400;
                 $ima->Scale( width=>400, height=>$ima->Get('height')/$factor );
    }
    if($ima->Get('height') > 500)
           {
           my $factor = $ima->Get('height')/500;
                   $ima->Scale( width=>$ima->Get('width')/$factor, height=>500);
           } 
   
    $ima->Write($img_url);
   }
   
 #Wrapper function for userphotoupload  #Wrapper function for userphotoupload
 sub userphotoupload  sub userphotoupload
Line 2123  sub finishuserfileupload { Line 2162  sub finishuserfileupload {
         $thumbwidth,$thumbheight) = @_;          $thumbwidth,$thumbheight) = @_;
     my $path=$docudom.'/'.$docuname.'/';      my $path=$docudom.'/'.$docuname.'/';
     my $filepath=$perlvar{'lonDocRoot'};      my $filepath=$perlvar{'lonDocRoot'};
     
     my ($fnamepath,$file,$fetchthumb);      my ($fnamepath,$file,$fetchthumb);
     $file=$fname;      $file=$fname;
     if ($fname=~m|/|) {      if ($fname=~m|/|) {
Line 2137  sub finishuserfileupload { Line 2177  sub finishuserfileupload {
     mkdir($filepath,0777);      mkdir($filepath,0777);
         }          }
     }      }
   
 # Save the file  # Save the file
     {      {
  if (!open(FH,'>'.$filepath.'/'.$file)) {   if (!open(FH,'>'.$filepath.'/'.$file)) {
Line 2152  sub finishuserfileupload { Line 2193  sub finishuserfileupload {
  close(FH);   close(FH);
  if($upload_photo_form==1)   if($upload_photo_form==1)
  {   {
  my $ima = Image::Magick->new;                          resizeImage($filepath.'/'.$file);
             $ima->Read($filepath.'/'.$file);  
  if($ima->Get('width') > 300)  
  {  
  my $factor = $ima->Get('width')/300;  
               $ima->Scale( width=>300, height=>$ima->Get('height')/$factor );  
  }  
  if($ima->Get('height') > 400)  
                 {  
                         my $factor = $ima->Get('height')/400;  
                         $ima->Scale( width=>$ima->Get('width')/$factor, height=>400);  
                 }  
    
   
  $ima->Write($filepath.'/'.$file);  
  $upload_photo_form = 0;   $upload_photo_form = 0;
  }   }
     }      }
Line 2190  sub finishuserfileupload { Line 2217  sub finishuserfileupload {
     
 # Notify homeserver to grep it  # Notify homeserver to grep it
 #  #
     my $docuhome=&homeserver($docuname,$docudom);      my $docuhome=&homeserver($docuname,$docudom);
     my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);      my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);
     if ($fetchresult eq 'ok') {      if ($fetchresult eq 'ok') {
         if ($fetchthumb) {          if ($fetchthumb) {
Line 2322  sub add_filetype { Line 2349  sub add_filetype {
 }  }
   
 sub removeuploadedurl {  sub removeuploadedurl {
     my ($url)=@_;      my ($url)=@_;
     my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);      my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);    
     return &removeuserfile($uname,$udom,$fname);      return &removeuserfile($uname,$udom,$fname);
 }  }
   
 sub removeuserfile {  sub removeuserfile {
     my ($docuname,$docudom,$fname)=@_;      my ($docuname,$docudom,$fname)=@_;
     my $home=&homeserver($docuname,$docudom);      my $home=&homeserver($docuname,$docudom);    
     my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home);      my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home);
     if ($result eq 'ok') {      if ($result eq 'ok') {
         if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) {          if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) {
             my $metafile = $fname.'.meta';              my $metafile = $fname.'.meta';
             my $metaresult = &removeuserfile($docuname,$docudom,$metafile);               my $metaresult = &removeuserfile($docuname,$docudom,$metafile); 
     my $url = "/uploaded/$docudom/$docuname/$fname";      my $url = "/uploaded/$docudom/$docuname/$fname";
             my ($file,$group) = (&parse_portfolio_url($url))[3,4];              my ($file,$group) = (&parse_portfolio_url($url))[3,4];   
             my $sqlresult =               my $sqlresult = 
                 &update_portfolio_table($docuname,$docudom,$file,                  &update_portfolio_table($docuname,$docudom,$file,
                                         'portfolio_metadata',$group,                                          'portfolio_metadata',$group,
Line 3842  sub del { Line 3869  sub del {
    foreach my $item (@$storearr) {     foreach my $item (@$storearr) {
        $items.=&escape($item).'&';         $items.=&escape($item).'&';
    }     }
   
    $items=~s/\&$//;     $items=~s/\&$//;
    if (!$udomain) { $udomain=$env{'user.domain'}; }     if (!$udomain) { $udomain=$env{'user.domain'}; }
    if (!$uname) { $uname=$env{'user.name'}; }     if (!$uname) { $uname=$env{'user.name'}; }
    my $uhome=&homeserver($uname,$udomain);     my $uhome=&homeserver($uname,$udomain);
   
    return &reply("del:$udomain:$uname:$namespace:$items",$uhome);     return &reply("del:$udomain:$uname:$namespace:$items",$uhome);
 }  }
   
Line 4407  sub is_portfolio_file { Line 4434  sub is_portfolio_file {
 }  }
   
 sub usertools_access {  sub usertools_access {
     my ($uname,$udom,$tool,$action) = @_;      my ($uname,$udom,$tool,$action,$context) = @_;
     my $access;      my ($access,%tools);
     my %tools = (      if ($context eq '') {
                   aboutme   => 1,          $context = 'tools';
                   blog      => 1,      }
                   portfolio => 1,      if ($context eq 'requestcourses') {
                 );          %tools = (
                         official   => 1,
                         unofficial => 1,
                    );
       } else {
           %tools = (
                         aboutme   => 1,
                         blog      => 1,
                         portfolio => 1,
                    );
       }
     return if (!defined($tools{$tool}));      return if (!defined($tools{$tool}));
   
     if ((!defined($udom)) || (!defined($uname))) {      if ((!defined($udom)) || (!defined($uname))) {
Line 4423  sub usertools_access { Line 4460  sub usertools_access {
   
     if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {      if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
         if ($action ne 'reload') {          if ($action ne 'reload') {
             return $env{'environment.availabletools.'.$tool};              if ($context eq 'requestcourses') {
         }                   return $env{'environment.canrequest.'.$tool};
               } else {
                   return $env{'environment.availabletools.'.$tool};
               }
           }
     }      }
   
     my ($toolstatus,$inststatus);      my ($toolstatus,$inststatus);
   
     if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {      if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) &&
         $toolstatus = $env{'environment.tools.'.$tool};           ($action ne 'reload')) {
           $toolstatus = $env{'environment.'.$context.'.'.$tool};
         $inststatus = $env{'environment.inststatus'};          $inststatus = $env{'environment.inststatus'};
     } else {      } else {
         my %userenv = &userenvironment($udom,$uname,'tools.'.$tool);          my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool);
         $toolstatus = $userenv{'tools.'.$tool};          $toolstatus = $userenv{$context.'.'.$tool};
         $inststatus = $userenv{'inststatus'};          $inststatus = $userenv{'inststatus'};
     }      }
   
Line 4490  sub usertools_access { Line 4532  sub usertools_access {
             }              }
         }          }
     } else {      } else {
         $access = 1;          if ($context eq 'tools') {
               $access = 1;
           } else {
               $access = 0;
           }
         return $access;          return $access;
     }      }
 }  }
Line 8966  sub get_dns { Line 9012  sub get_dns {
     }      }
 }  }
   
   #
   #  Given a DNS returns the loncapa host name for that DNS 
   # 
   sub host_from_dns {
       my ($dns) = @_;
       my @hosts;
       my $ip;
   
       $ip = gethostbyname($dns); # Initial translation to IP is in net order.
       if (length($ip) == 4) { 
    $ip   = &IO::Socket::inet_ntoa($ip);
    @hosts = get_hosts_from_ip($ip);
    return $hosts[0];
       }
       return undef;
   }
   
 BEGIN {  BEGIN {
   
 # ----------------------------------- Read loncapa.conf and loncapa_apache.conf  # ----------------------------------- Read loncapa.conf and loncapa_apache.conf
Line 9855  dirlist($uri) : return directory list ba Line 9918  dirlist($uri) : return directory list ba
   
 spareserver() : find server with least workload from spare.tab  spareserver() : find server with least workload from spare.tab
   
   
   =item *
   
   host_from_dns($dns) : Returns the loncapa hostname corresponding to a DNS name or undef
   if there is no corresponding loncapa host.
   
 =back  =back
   
   
 =head2 Apache Request  =head2 Apache Request
   
 =over 4  =over 4
Removed from v.1.982  
changed lines
  Added in v.1.986

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>