[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.976.2.9 and 1.986

version 1.976.2.9, 2009/05/15 20:31:04 version 1.986, 2009/02/10 11:15:16
Line 73  package Apache::lonnet; Line 73  package Apache::lonnet;
 use strict;  use strict;
 use LWP::UserAgent();  use LWP::UserAgent();
 use HTTP::Date;  use HTTP::Date;
   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
             $_64bit %env %protocol);              $_64bit %env %protocol);
Line 97  use LONCAPA::Configuration; Line 100  use LONCAPA::Configuration;
 my $readit;  my $readit;
 my $max_connection_retries = 10;     # Or some such value.  my $max_connection_retries = 10;     # Or some such value.
   
   my $upload_photo_form = 0; #Variable to check  when user upload a photo 0=not 1=true
   
 require Exporter;  require Exporter;
   
 our @ISA = qw (Exporter);  our @ISA = qw (Exporter);
Line 146  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 522  sub appenv { Line 528  sub appenv {
 # ----------------------------------------------------- Delete from Environment  # ----------------------------------------------------- Delete from Environment
   
 sub delenv {  sub delenv {
     my ($delthis,$regexp) = @_;      my $delthis=shift;
     if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {      if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {
         &logthis("<font color=\"blue\">WARNING: ".          &logthis("<font color=\"blue\">WARNING: ".
                 "Attempt to delete from environment ".$delthis);                  "Attempt to delete from environment ".$delthis);
Line 535  sub delenv { Line 541  sub delenv {
  tie(my %disk_env,'GDBM_File',$env{'user.environment'},   tie(my %disk_env,'GDBM_File',$env{'user.environment'},
     (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {      (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
  foreach my $key (keys(%disk_env)) {   foreach my $key (keys(%disk_env)) {
             if ($regexp) {      if ($key=~/^\Q$delthis\E/) { 
                 if ($key=~/^$delthis/) {   delete($env{$key});
                     delete($env{$key});   delete($disk_env{$key});
                     delete($disk_env{$key});      }
                 }  
             } else {  
                 if ($key=~/^\Q$delthis\E/) {  
                     delete($env{$key});  
                     delete($disk_env{$key});  
                 }  
             }  
  }   }
  untie(%disk_env);   untie(%disk_env);
     }      }
Line 1281  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 2032  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
   sub userphotoupload
   {
    my($formname,$subdir) = @_;
    $upload_photo_form = 1;
    return &userfileupload($formname,undef,$subdir);
   }
   
 # --------------- Take an uploaded file and put it into the userfiles directory  # --------------- Take an uploaded file and put it into the userfiles directory
 # input: $formname - the contents of the file are in $env{"form.$formname"}  # input: $formname - the contents of the file are in $env{"form.$formname"}
Line 2132  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 2146  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 2159  sub finishuserfileupload { Line 2191  sub finishuserfileupload {
     return '/adm/notfound.html';      return '/adm/notfound.html';
  }   }
  close(FH);   close(FH);
    if($upload_photo_form==1)
    {
    resizeImage($filepath.'/'.$file);
    $upload_photo_form = 0;
    }
     }      }
     if ($parser eq 'parse') {      if ($parser eq 'parse') {
         my $parse_result = &extract_embedded_items($filepath.'/'.$file,$allfiles,          my $parse_result = &extract_embedded_items($filepath.'/'.$file,$allfiles,
Line 2180  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 2312  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 2624  sub courserolelog { Line 2661  sub courserolelog {
                 $storehash{'section'} = $sec;                  $storehash{'section'} = $sec;
             }              }
             &instructor_log($namespace,\%storehash,$delflag,$username,$domain,$cnum,$cdom);              &instructor_log($namespace,\%storehash,$delflag,$username,$domain,$cnum,$cdom);
             if (($trole ne 'st') || ($sec ne '')) {  
                 &devalidate_cache_new('getcourseroles',$cdom.'_'.$cnum);  
             }  
         }          }
     }      }
     return;      return;
Line 2648  sub get_course_adv_roles { Line 2682  sub get_course_adv_roles {
     my %dumphash=      my %dumphash=
             &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});              &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});
     my $now=time;      my $now=time;
     my %privileged;  
     foreach my $entry (keys %dumphash) {      foreach my $entry (keys %dumphash) {
  my ($tend,$tstart)=split(/\:/,$dumphash{$entry});   my ($tend,$tstart)=split(/\:/,$dumphash{$entry});
         if (($tstart) && ($tstart<0)) { next; }          if (($tstart) && ($tstart<0)) { next; }
Line 2656  sub get_course_adv_roles { Line 2689  sub get_course_adv_roles {
         if (($tstart) && ($now<$tstart)) { next; }          if (($tstart) && ($now<$tstart)) { next; }
         my ($role,$username,$domain,$section)=split(/\:/,$entry);          my ($role,$username,$domain,$section)=split(/\:/,$entry);
  if ($username eq '' || $domain eq '') { next; }   if ($username eq '' || $domain eq '') { next; }
         unless (ref($privileged{$domain}) eq 'HASH') {   if ((&privileged($username,$domain)) && 
             my %dompersonnel =      (!$nothide{$username.':'.$domain})) { next; }
                 &Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now);  
             $privileged{$domain} = {};  
             foreach my $server (keys(%dompersonnel)) {  
                 if (ref($dompersonnel{$server}) eq 'HASH') {  
                     foreach my $user (keys(%{$dompersonnel{$server}})) {  
                         my ($trole,$uname,$udom) = split(/:/,$user);  
                         $privileged{$udom}{$uname} = 1;  
                     }  
                 }  
             }  
         }  
         if ((exists($privileged{$domain}{$username})) &&  
             (!$nothide{$username.':'.$domain})) { next; }  
  if ($role eq 'cr') { next; }   if ($role eq 'cr') { next; }
         if ($codes) {          if ($codes) {
             if ($section) { $role .= ':'.$section; }              if ($section) { $role .= ':'.$section; }
Line 2715  sub get_my_roles { Line 2735  sub get_my_roles {
     }      }
     my %returnhash=();      my %returnhash=();
     my $now=time;      my $now=time;
     my %privileged;  
     foreach my $entry (keys(%dumphash)) {      foreach my $entry (keys(%dumphash)) {
         my ($role,$tend,$tstart);          my ($role,$tend,$tstart);
         if ($context eq 'userroles') {          if ($context eq 'userroles') {
Line 2764  sub get_my_roles { Line 2783  sub get_my_roles {
             }              }
         }          }
         if ($hidepriv) {          if ($hidepriv) {
             if ($context eq 'userroles') {              if ((&privileged($username,$domain)) &&
                 if ((&privileged($username,$domain)) &&                  (!$nothide{$username.':'.$domain})) { 
                     (!$nothide{$username.':'.$domain})) {                  next;
                     next;  
                 }  
             } else {  
                 unless (ref($privileged{$domain}) eq 'HASH') {  
                     my %dompersonnel =  
                         &Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now);  
                     $privileged{$domain} = {};  
                     if (keys(%dompersonnel)) {  
                         foreach my $server (keys(%dompersonnel)) {  
                             if (ref($dompersonnel{$server}) eq 'HASH') {  
                                 foreach my $user (keys(%{$dompersonnel{$server}})) {  
                                     my ($trole,$uname,$udom) = split(/:/,$user);  
                                     $privileged{$udom}{$uname} = $trole;  
                                 }  
                             }  
                         }  
                     }  
                 }  
                 if (exists($privileged{$domain}{$username})) {  
                     if (!$nothide{$username.':'.$domain}) {  
                         next;  
                     }  
                 }  
             }              }
         }          }
         if ($withsec) {          if ($withsec) {
Line 3873  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 4438  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 4454  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 4521  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 8997  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 9276  in the user's environment.db and in %env Line 9308  in the user's environment.db and in %env
   
 =item *  =item *
 X<delenv()>  X<delenv()>
 B<delenv($delthis,$regexp)>: removes all items from the session  B<delenv($regexp)>: removes all items from the session
 environment file that begin with $delthis. If the  environment file that matches the regular expression in $regexp. The
 optional second arg - $regexp - is true, $delthis is treated as a  values are also delted from the current processes %env.
 regular expression, otherwise \Q$delthis\E is used.  
 The values are also deleted from the current processes %env.  
   
 =item * get_env_multiple($name)   =item * get_env_multiple($name) 
   
Line 9888  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.976.2.9  
changed lines
  Added in v.1.986

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