[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.587.2.3.2.11 and 1.603

version 1.587.2.3.2.11, 2005/02/14 04:29:43 version 1.603, 2005/03/03 05:45:50
Line 35  use HTTP::Headers; Line 35  use HTTP::Headers;
 use HTTP::Date;  use HTTP::Date;
 # use Date::Parse;  # use Date::Parse;
 use vars   use vars 
 qw(%perlvar %hostname %badServerCache %hostip %iphost %spareid %hostdom   qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom 
    %libserv %pr %prp $memcache %packagetab      %libserv %pr %prp $memcache %packagetab 
    %courselogs %accesshash %userrolehash $processmarker $dumpcount      %courselogs %accesshash %userrolehash $processmarker $dumpcount 
    %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf     %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf
Line 559  sub authenticate { Line 559  sub authenticate {
   
 # ---------------------- Find the homebase for a user from domain's lib servers  # ---------------------- Find the homebase for a user from domain's lib servers
   
   my %homecache;
 sub homeserver {  sub homeserver {
     my ($uname,$udom,$ignoreBadCache)=@_;      my ($uname,$udom,$ignoreBadCache)=@_;
     my $index="$uname:$udom";      my $index="$uname:$udom";
   
     my ($result,$cached)=&is_cached_new('home',$index);      if (exists($homecache{$index})) { return $homecache{$index}; }
     if (defined($cached)) { return $result; }  
     my $tryserver;      my $tryserver;
     foreach $tryserver (keys %libserv) {      foreach $tryserver (keys %libserv) {
         next if ($ignoreBadCache ne 'true' &&           next if ($ignoreBadCache ne 'true' && 
Line 572  sub homeserver { Line 572  sub homeserver {
  if ($hostdom{$tryserver} eq $udom) {   if ($hostdom{$tryserver} eq $udom) {
            my $answer=reply("home:$udom:$uname",$tryserver);             my $answer=reply("home:$udom:$uname",$tryserver);
            if ($answer eq 'found') {              if ($answer eq 'found') { 
        return &do_cache_new('home',$index,$tryserver,86400);         return $homecache{$index}=$tryserver;
            } elsif ($answer eq 'no_host') {             } elsif ($answer eq 'no_host') {
        $badServerCache{$tryserver}=1;         $badServerCache{$tryserver}=1;
            }             }
Line 782  sub getsection { Line 782  sub getsection {
     $courseid=~s/^(\w)/\/$1/;      $courseid=~s/^(\w)/\/$1/;
   
     my $hashid="$udom:$unam:$courseid";      my $hashid="$udom:$unam:$courseid";
     my ($result,$cached)=&is_cached_new('getsection',$hashid,1);      my ($result,$cached)=&is_cached_new('getsection',$hashid);
     if (defined($cached)) { return $result; }      if (defined($cached)) { return $result; }
   
     my %Pending;       my %Pending; 
Line 834  sub getsection { Line 834  sub getsection {
     return &do_cache_new('getsection',$hashid,'-1',$cachetime);      return &do_cache_new('getsection',$hashid,'-1',$cachetime);
 }  }
   
   
 my $disk_caching_disabled=1;  
   
 sub devalidate_cache {  
     my ($cache,$id,$name) = @_;  
     delete $$cache{$id.'.time'};  
     delete $$cache{$id.'.file'};  
     delete $$cache{$id};  
     if (1 || $disk_caching_disabled) { return; }  
     my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";  
     if (!-e $filename) { return; }  
     open(DB,">$filename.lock");  
     flock(DB,LOCK_EX);  
     my %hash;  
     if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {  
  eval <<'EVALBLOCK';  
     delete($hash{$id});  
     delete($hash{$id.'.time'});  
 EVALBLOCK  
         if ($@) {  
     &logthis("<font color='red'>devalidate_cache blew up :$@:$name</font>");  
     unlink($filename);  
  }  
     } else {  
  if (-e $filename) {  
     &logthis("Unable to tie hash (devalidate cache): $name");  
     unlink($filename);  
  }  
     }  
     untie(%hash);  
     flock(DB,LOCK_UN);  
     close(DB);  
 }  
   
 sub is_cached {  
     my ($cache,$id,$name,$time) = @_;  
     if (!$time) { $time=300; }  
     if (!exists($$cache{$id.'.time'})) {  
  &load_cache_item($cache,$name,$id,$time);  
     }  
     if (!exists($$cache{$id.'.time'})) {  
 # &logthis("Didn't find $id");  
  return (undef,undef);  
     } else {  
  if (time-($$cache{$id.'.time'})>$time) {  
     if (exists($$cache{$id.'.file'})) {  
  foreach my $filename (@{ $$cache{$id.'.file'} }) {  
     my $mtime=(stat($filename))[9];  
     #+1 is to take care of edge effects  
     if ($mtime && (($mtime+1) < ($$cache{$id.'.time'}))) {  
 # &logthis("Upping $mtime - ".$$cache{$id.'.time'}.  
 # "$id because of $filename");  
     } else {  
  &logthis("Devalidating $filename $id - ".(time-($$cache{$id.'.time'})));  
  &devalidate_cache($cache,$id,$name);  
  return (undef,undef);  
     }  
  }  
  $$cache{$id.'.time'}=time;  
     } else {  
 # &logthis("Devalidating $id - ".time-($$cache{$id.'.time'}));  
  &devalidate_cache($cache,$id,$name);  
  return (undef,undef);  
     }  
  }  
     }  
     return ($$cache{$id},1);  
 }  
   
 sub do_cache {  
     my ($cache,$id,$value,$name) = @_;  
     $$cache{$id.'.time'}=time;  
     $$cache{$id}=$value;  
 #    &logthis("Caching $id as :$value:");  
     &save_cache_item($cache,$name,$id);  
     # do_cache implictly return the set value  
     $$cache{$id};  
 }  
   
 my %do_save_item;  
 my %do_save;  
 sub save_cache_item {  
     my ($cache,$name,$id)=@_;  
     if ($disk_caching_disabled) { return; }  
     $do_save{$name}=$cache;  
     if (!exists($do_save_item{$name})) { $do_save_item{$name}={} }  
     $do_save_item{$name}->{$id}=1;  
     return;  
 }  
   
 sub save_cache {  sub save_cache {
     &purge_remembered();      &purge_remembered();
     if ($disk_caching_disabled) { return; }  
     my ($cache,$name,$id);  
     foreach $name (keys(%do_save)) {  
  $cache=$do_save{$name};  
   
  my $starttime=&Time::HiRes::time();  
  &logthis("Saving :$name:");  
  my %hash;  
  my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";  
  open(DB,">$filename.lock");  
  flock(DB,LOCK_EX);  
  if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {  
     foreach $id (keys(%{ $do_save_item{$name} })) {  
  eval <<'EVALBLOCK';  
  $hash{$id.'.time'}=$$cache{$id.'.time'};  
  $hash{$id}=freeze({'item'=>$$cache{$id}});  
  if (exists($$cache{$id.'.file'})) {  
     $hash{$id.'.file'}=freeze({'item'=>$$cache{$id.'.file'}});  
  }  
 EVALBLOCK  
                 if ($@) {  
     &logthis("<font color='red'>save_cache blew up :$@:$name</font>");  
     unlink($filename);  
     last;  
  }  
     }  
  } else {  
     if (-e $filename) {  
  &logthis("Unable to tie hash (save cache): $name ($!)");  
  unlink($filename);  
     }  
  }  
  untie(%hash);  
  flock(DB,LOCK_UN);  
  close(DB);  
  &logthis("save_cache $name took ".(&Time::HiRes::time()-$starttime));  
     }  
     undef(%do_save);  
     undef(%do_save_item);  
   
 }  
   
 sub load_cache_item {  
     my ($cache,$name,$id,$time)=@_;  
     if ($disk_caching_disabled) { return; }  
     my $starttime=&Time::HiRes::time();  
 #    &logthis("Before Loading $name  for $id size is ".scalar(%$cache));  
     my %hash;  
     my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";  
     if (!-e $filename) { return; }  
     open(DB,">$filename.lock");  
     flock(DB,LOCK_SH);  
     if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) {  
  eval <<'EVALBLOCK';  
     if (!%$cache) {  
  my $count;  
  while (my ($key,$value)=each(%hash)) {   
     $count++;  
     if ($key =~ /\.time$/) {  
  $$cache{$key}=$value;  
     } else {  
  my $hashref=thaw($value);  
  $$cache{$key}=$hashref->{'item'};  
     }  
  }  
 #    &logthis("Initial load: $count");  
     } else {  
  if (($$cache{$id.'.time'}+$time) < time) {  
     $$cache{$id.'.time'}=$hash{$id.'.time'};  
     {  
  my $hashref=thaw($hash{$id});  
  $$cache{$id}=$hashref->{'item'};  
     }  
     if (exists($hash{$id.'.file'})) {  
  my $hashref=thaw($hash{$id.'.file'});  
  $$cache{$id.'.file'}=$hashref->{'item'};  
     }  
  }  
     }  
 EVALBLOCK  
         if ($@) {  
     &logthis("<font color='red'>load_cache blew up :$@:$name</font>");  
     unlink($filename);  
  }          
     } else {  
  if (-e $filename) {  
     &logthis("Unable to tie hash (load cache item): $name ($!)");  
     unlink($filename);  
  }  
     }  
     untie(%hash);  
     flock(DB,LOCK_UN);  
     close(DB);  
 #    &logthis("After Loading $name size is ".scalar(%$cache));  
 #    &logthis("load_cache_item $name took ".(&Time::HiRes::time()-$starttime));  
 }  }
   
 my $to_remember=10;  my $to_remember=-1;
 my %remembered;  my %remembered;
 my %accessed;  my %accessed;
 my $kicks=0;  my $kicks=0;
Line 1051  sub is_cached_new { Line 866  sub is_cached_new {
  if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); }   if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); }
  return (undef,undef);   return (undef,undef);
     }      }
     &make_room($id,$value,$debug);  
     if ($value eq '__undef__') {      if ($value eq '__undef__') {
  if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); }   if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); }
  return (undef,1);   $value=undef;
     }      }
       &make_room($id,$value,$debug);
     if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); }      if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); }
     return ($value,1);      return ($value,1);
 }  }
Line 1068  sub do_cache_new { Line 883  sub do_cache_new {
  $setvalue='__undef__';   $setvalue='__undef__';
     }      }
     if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }      if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }
     $memcache->set($id,$setvalue,300);      $memcache->set($id,$setvalue,$time);
     &make_room($id,$value,$debug);      # need to make a copy of $value
       #&make_room($id,$value,$debug);
     return $value;      return $value;
 }  }
   
 sub make_room {  sub make_room {
     my ($id,$value,$debug)=@_;      my ($id,$value,$debug)=@_;
     $remembered{$id}=$value;      $remembered{$id}=$value;
       if ($to_remember<0) { return; }
     $accessed{$id}=[&gettimeofday()];      $accessed{$id}=[&gettimeofday()];
     if (scalar(keys(%remembered)) <= $to_remember) { return; }      if (scalar(keys(%remembered)) <= $to_remember) { return; }
     my $to_kick;      my $to_kick;
Line 1089  sub make_room { Line 906  sub make_room {
     delete($remembered{$to_kick});      delete($remembered{$to_kick});
     delete($accessed{$to_kick});      delete($accessed{$to_kick});
     $kicks++;      $kicks++;
     if ($debug) { &logthis("kicking $max_time $kicks\n"); }      if ($debug) { &logthis("kicking $to_kick $max_time $kicks\n"); }
     return;      return;
 }  }
   
 sub purge_remembered {  sub purge_remembered {
     &logthis("Tossing ".scalar(keys(%remembered)));      &logthis("Tossing ".scalar(keys(%remembered)));
       &logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered))));
     undef(%remembered);      undef(%remembered);
     undef(%accessed);      undef(%accessed);
 }  }
Line 1176  sub subscribe { Line 994  sub subscribe {
 sub repcopy {  sub repcopy {
     my $filename=shift;      my $filename=shift;
     $filename=~s/\/+/\//g;      $filename=~s/\/+/\//g;
     if ($filename=~m|^/home/httpd/html/adm/|) { return OK; }      if ($filename=~m|^/home/httpd/html/adm/|) { return 'OK'; }
     if ($filename=~m|^/home/httpd/html/lonUsers/|) { return OK; }      if ($filename=~m|^/home/httpd/html/lonUsers/|) { return 'OK'; }
     if ($filename=~m|^/home/httpd/html/userfiles/| or      if ($filename=~m|^/home/httpd/html/userfiles/| or
  $filename=~m|^/*uploaded/|) {    $filename=~m|^/*uploaded/|) { 
  return &repcopy_userfile($filename);   return &repcopy_userfile($filename);
     }      }
     $filename=~s/[\n\r]//g;      $filename=~s/[\n\r]//g;
     my $transname="$filename.in.transfer";      my $transname="$filename.in.transfer";
     if ((-e $filename) || (-e $transname)) { return OK; }      if ((-e $filename) || (-e $transname)) { return 'OK'; }
     my $remoteurl=subscribe($filename);      my $remoteurl=subscribe($filename);
     if ($remoteurl =~ /^con_lost by/) {      if ($remoteurl =~ /^con_lost by/) {
    &logthis("Subscribe returned $remoteurl: $filename");     &logthis("Subscribe returned $remoteurl: $filename");
            return HTTP_SERVICE_UNAVAILABLE;             return 'HTTP_SERVICE_UNAVAILABLE';
     } elsif ($remoteurl eq 'not_found') {      } elsif ($remoteurl eq 'not_found') {
    #&logthis("Subscribe returned not_found: $filename");     #&logthis("Subscribe returned not_found: $filename");
    return HTTP_NOT_FOUND;     return 'HTTP_NOT_FOUND';
     } elsif ($remoteurl =~ /^rejected by/) {      } elsif ($remoteurl =~ /^rejected by/) {
    &logthis("Subscribe returned $remoteurl: $filename");     &logthis("Subscribe returned $remoteurl: $filename");
            return FORBIDDEN;             return 'FORBIDDEN';
     } elsif ($remoteurl eq 'directory') {      } elsif ($remoteurl eq 'directory') {
            return OK;             return 'OK';
     } else {      } else {
         my $author=$filename;          my $author=$filename;
         $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;          $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
Line 1207  sub repcopy { Line 1025  sub repcopy {
            my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";             my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";
            if ($path ne "$perlvar{'lonDocRoot'}/res") {             if ($path ne "$perlvar{'lonDocRoot'}/res") {
                &logthis("Malconfiguration for replication: $filename");                 &logthis("Malconfiguration for replication: $filename");
        return HTTP_BAD_REQUEST;         return 'HTTP_BAD_REQUEST';
            }             }
            my $count;             my $count;
            for ($count=5;$count<$#parts;$count++) {             for ($count=5;$count<$#parts;$count++) {
Line 1224  sub repcopy { Line 1042  sub repcopy {
                my $message=$response->status_line;                 my $message=$response->status_line;
                &logthis("<font color=blue>WARNING:"                 &logthis("<font color=blue>WARNING:"
                        ." LWP get: $message: $filename</font>");                         ." LWP get: $message: $filename</font>");
                return HTTP_SERVICE_UNAVAILABLE;                 return 'HTTP_SERVICE_UNAVAILABLE';
            } else {             } else {
        if ($remoteurl!~/\.meta$/) {         if ($remoteurl!~/\.meta$/) {
                   my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');                    my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');
Line 1236  sub repcopy { Line 1054  sub repcopy {
                   }                    }
        }         }
                rename($transname,$filename);                 rename($transname,$filename);
                return OK;                 return 'OK';
            }             }
        }         }
     }      }
Line 1817  sub get_first_access { Line 1635  sub get_first_access {
     my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();      my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();
     if ($argsymb) { $symb=$argsymb; }      if ($argsymb) { $symb=$argsymb; }
     my ($map,$id,$res)=&decode_symb($symb);      my ($map,$id,$res)=&decode_symb($symb);
     if ($type eq 'map') { $res=$map; }      if ($type eq 'map') {
     my %times=&get('firstaccesstimes',[$res],$udom,$uname);   $res=&symbread($map);
     return $times{$res};      } else {
    $res=$symb;
       }
       my %times=&get('firstaccesstimes',["$courseid\0$res"],$udom,$uname);
       return $times{"$courseid\0$res"};
 }  }
   
 sub set_first_access {  sub set_first_access {
     my ($type)=@_;      my ($type)=@_;
     my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();      my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();
     my ($map,$id,$res)=&decode_symb($symb);      my ($map,$id,$res)=&decode_symb($symb);
     if ($type eq 'map') { $res=$map; }      if ($type eq 'map') {
     my $firstaccess=&get_first_access($type);   $res=&symbread($map);
       } else {
    $res=$symb;
       }
       my $firstaccess=&get_first_access($type,$symb);
     if (!$firstaccess) {      if (!$firstaccess) {
  return &put('firstaccesstimes',{$res=>time},$udom,$uname);   return &put('firstaccesstimes',{"$courseid\0$res"=>time},$udom,$uname);
     }      }
     return 'already_set';      return 'already_set';
 }  }
Line 1887  sub checkin { Line 1713  sub checkin {
     my $now=time;      my $now=time;
     my ($ta,$tb,$lonhost)=split(/\*/,$token);      my ($ta,$tb,$lonhost)=split(/\*/,$token);
     $lonhost=~tr/A-Z/a-z/;      $lonhost=~tr/A-Z/a-z/;
     my $dtoken=$ta.'_'.$hostip{$lonhost}.'_'.$tb;      my $dtoken=$ta.'_'.$hostname{$lonhost}.'_'.$tb;
     $dtoken=~s/\W/\_/g;      $dtoken=~s/\W/\_/g;
     my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=      my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
                  split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));                   split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
Line 2170  sub tmpreset { Line 1996  sub tmpreset {
   $namespace=~s/\//\_/g;    $namespace=~s/\//\_/g;
   $namespace=~s/\W//g;    $namespace=~s/\W//g;
   
   #FIXME needs to do something for /pub resources  
   if (!$domain) { $domain=$ENV{'user.domain'}; }    if (!$domain) { $domain=$ENV{'user.domain'}; }
   if (!$stuname) { $stuname=$ENV{'user.name'}; }    if (!$stuname) { $stuname=$ENV{'user.name'}; }
     if ($domain eq 'public' && $stuname eq 'public') {
         $stuname=$ENV{'REMOTE_ADDR'};
     }
   my $path=$perlvar{'lonDaemons'}.'/tmp';    my $path=$perlvar{'lonDaemons'}.'/tmp';
   my %hash;    my %hash;
   if (tie(%hash,'GDBM_File',    if (tie(%hash,'GDBM_File',
Line 2205  sub tmpstore { Line 2033  sub tmpstore {
   }    }
   $namespace=~s/\//\_/g;    $namespace=~s/\//\_/g;
   $namespace=~s/\W//g;    $namespace=~s/\W//g;
 #FIXME needs to do something for /pub resources  
   if (!$domain) { $domain=$ENV{'user.domain'}; }    if (!$domain) { $domain=$ENV{'user.domain'}; }
   if (!$stuname) { $stuname=$ENV{'user.name'}; }    if (!$stuname) { $stuname=$ENV{'user.name'}; }
     if ($domain eq 'public' && $stuname eq 'public') {
         $stuname=$ENV{'REMOTE_ADDR'};
     }
   my $now=time;    my $now=time;
   my %hash;    my %hash;
   my $path=$perlvar{'lonDaemons'}.'/tmp';    my $path=$perlvar{'lonDaemons'}.'/tmp';
Line 2219  sub tmpstore { Line 2049  sub tmpstore {
     my $allkeys='';       my $allkeys=''; 
     foreach my $key (keys(%$storehash)) {      foreach my $key (keys(%$storehash)) {
       $allkeys.=$key.':';        $allkeys.=$key.':';
       $hash{"$version:$symb:$key"}=$$storehash{$key};        $hash{"$version:$symb:$key"}=&freeze_escape($$storehash{$key});
     }      }
     $hash{"$version:$symb:timestamp"}=$now;      $hash{"$version:$symb:timestamp"}=$now;
     $allkeys.='timestamp';      $allkeys.='timestamp';
Line 2246  sub tmprestore { Line 2076  sub tmprestore {
   $symb=escape($symb);    $symb=escape($symb);
   
   if (!$namespace) { $namespace=$ENV{'request.state'}; }    if (!$namespace) { $namespace=$ENV{'request.state'}; }
   #FIXME needs to do something for /pub resources  
   if (!$domain) { $domain=$ENV{'user.domain'}; }    if (!$domain) { $domain=$ENV{'user.domain'}; }
   if (!$stuname) { $stuname=$ENV{'user.name'}; }    if (!$stuname) { $stuname=$ENV{'user.name'}; }
     if ($domain eq 'public' && $stuname eq 'public') {
         $stuname=$ENV{'REMOTE_ADDR'};
     }
   my %returnhash;    my %returnhash;
   $namespace=~s/\//\_/g;    $namespace=~s/\//\_/g;
   $namespace=~s/\W//g;    $namespace=~s/\W//g;
Line 2267  sub tmprestore { Line 2099  sub tmprestore {
       my $key;        my $key;
       $returnhash{"$scope:keys"}=$vkeys;        $returnhash{"$scope:keys"}=$vkeys;
       foreach $key (@keys) {        foreach $key (@keys) {
  $returnhash{"$scope:$key"}=$hash{"$scope:$symb:$key"};   $returnhash{"$scope:$key"}=&thaw_unescape($hash{"$scope:$symb:$key"});
  $returnhash{"$key"}=$hash{"$scope:$symb:$key"};   $returnhash{"$key"}=&thaw_unescape($hash{"$scope:$symb:$key"});
       }        }
     }      }
     if (!(untie(%hash))) {      if (!(untie(%hash))) {
Line 2309  sub store { Line 2141  sub store {
   
     my $namevalue='';      my $namevalue='';
     foreach (keys %$storehash) {      foreach (keys %$storehash) {
         $namevalue.=escape($_).'='.escape($$storehash{$_}).'&';          $namevalue.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&';
     }      }
     $namevalue=~s/\&$//;      $namevalue=~s/\&$//;
     &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue);      &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue);
Line 2345  sub cstore { Line 2177  sub cstore {
   
     my $namevalue='';      my $namevalue='';
     foreach (keys %$storehash) {      foreach (keys %$storehash) {
         $namevalue.=escape($_).'='.escape($$storehash{$_}).'&';          $namevalue.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&';
     }      }
     $namevalue=~s/\&$//;      $namevalue=~s/\&$//;
     &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);      &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);
Line 2379  sub restore { Line 2211  sub restore {
     my %returnhash=();      my %returnhash=();
     foreach (split(/\&/,$answer)) {      foreach (split(/\&/,$answer)) {
  my ($name,$value)=split(/\=/,$_);   my ($name,$value)=split(/\=/,$_);
         $returnhash{&unescape($name)}=&unescape($value);          $returnhash{&unescape($name)}=&thaw_unescape($value);
     }      }
     my $version;      my $version;
     for ($version=1;$version<=$returnhash{'version'};$version++) {      for ($version=1;$version<=$returnhash{'version'};$version++) {
Line 2770  sub putstore { Line 2602  sub putstore {
            my $key = $1.':keys:'.$2;             my $key = $1.':keys:'.$2;
            $allitems{$key} .= $3.':';             $allitems{$key} .= $3.':';
        }         }
        $items.=$_.'='.&escape($$storehash{$_}).'&';         $items.=$_.'='.&freeze_escape($$storehash{$_}).'&';
    }     }
    foreach (keys %allitems) {     foreach (keys %allitems) {
        $allitems{$_} =~ s/\:$//;         $allitems{$_} =~ s/\:$//;
Line 3640  sub modifyuser { Line 3472  sub modifyuser {
     if (defined($middle)) { $names{'middlename'} = $middle; }      if (defined($middle)) { $names{'middlename'} = $middle; }
     if ($last)   { $names{'lastname'}   = $last; }      if ($last)   { $names{'lastname'}   = $last; }
     if (defined($gene))   { $names{'generation'} = $gene; }      if (defined($gene))   { $names{'generation'} = $gene; }
     if ($email)  { $names{'notification'} = $email;      if ($email) {
                    $names{'critnotification'} = $email; }         $email=~s/[^\w\@\.\-\,]//gs;
          if ($email=~/\@/) { $names{'notification'} = $email;
      $names{'critnotification'} = $email;
      $names{'permanentemail'} = $email; }
       }
     my $reply = &put('environment', \%names, $udom,$uname);      my $reply = &put('environment', \%names, $udom,$uname);
     if ($reply ne 'ok') { return 'error: '.$reply; }      if ($reply ne 'ok') { return 'error: '.$reply; }
     &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.      &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
Line 4374  sub EXT { Line 4209  sub EXT {
  if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) {   if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) {
     if (!$symbparm) { $symbparm=&symbread(); }      if (!$symbparm) { $symbparm=&symbread(); }
  }   }
    my ($courselevelm,$courselevel);
  if ($symbparm && defined($courseid) &&    if ($symbparm && defined($courseid) && 
     $courseid eq $ENV{'request.course.id'}) {      $courseid eq $ENV{'request.course.id'}) {
   
Line 4401  sub EXT { Line 4237  sub EXT {
     my $seclevelr=$courseid.'.['.$section.'].'.$symbparm;      my $seclevelr=$courseid.'.['.$section.'].'.$symbparm;
     my $seclevelm=$courseid.'.['.$section.'].'.$mapparm;      my $seclevelm=$courseid.'.['.$section.'].'.$mapparm;
   
     my $courselevel=$courseid.'.'.$spacequalifierrest;      $courselevel=$courseid.'.'.$spacequalifierrest;
     my $courselevelr=$courseid.'.'.$symbparm;      my $courselevelr=$courseid.'.'.$symbparm;
     my $courselevelm=$courseid.'.'.$mapparm;      $courselevelm=$courseid.'.'.$mapparm;
   
 # ----------------------------------------------------------- first, check user  # ----------------------------------------------------------- first, check user
     #most student don\'t have any data set, check if there is some data      #most student don\'t have any data set, check if there is some data
Line 4438  sub EXT { Line 4274  sub EXT {
  }   }
     }      }
   
 # -------------------------------------------------------- second, check course  # ------------------------------------------------ second, check some of course
   
     my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'},      my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'},
    $ENV{'course.'.$courseid.'.domain'},     $ENV{'course.'.$courseid.'.domain'},
    ($seclevelr,$seclevelm,$seclevel,     ($seclevelr,$seclevelm,$seclevel,
     $courselevelr,$courselevelm,      $courselevelr));
     $courselevel));  
     if (defined($coursereply)) { return $coursereply; }      if (defined($coursereply)) { return $coursereply; }
   
 # ------------------------------------------------------ third, check map parms  # ------------------------------------------------------ third, check map parms
Line 4458  sub EXT { Line 4293  sub EXT {
     }      }
     if ($thisparm) { return $thisparm; }      if ($thisparm) { return $thisparm; }
  }   }
 # --------------------------------------------- last, look in resource metadata  # ------------------------------------------ fourth, look in resource metadata
   
  $spacequalifierrest=~s/\./\_/;   $spacequalifierrest=~s/\./\_/;
  my $filename;   my $filename;
Line 4473  sub EXT { Line 4308  sub EXT {
  $metadata=&metadata($filename,'parameter_'.$spacequalifierrest);   $metadata=&metadata($filename,'parameter_'.$spacequalifierrest);
  if (defined($metadata)) { return $metadata; }   if (defined($metadata)) { return $metadata; }
   
   # ---------------------------------------------- fourth, look in rest pf course
    if ($symbparm && defined($courseid) && 
       $courseid eq $ENV{'request.course.id'}) {
       my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'},
      $ENV{'course.'.$courseid.'.domain'},
      ($courselevelm,$courselevel));
       if (defined($coursereply)) { return $coursereply; }
    }
 # ------------------------------------------------------------------ Cascade up  # ------------------------------------------------------------------ Cascade up
  unless ($space eq '0') {   unless ($space eq '0') {
     my @parts=split(/_/,$space);      my @parts=split(/_/,$space);
Line 4833  sub symblist { Line 4676  sub symblist {
         if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',          if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',
                       &GDBM_WRCREAT(),0640)) {                        &GDBM_WRCREAT(),0640)) {
     foreach (keys %newhash) {      foreach (keys %newhash) {
                 $hash{declutter($_)}=$mapname.'___'.&deversion($newhash{$_});                  $hash{declutter($_)}=&encode_symb($mapname,$newhash{$_}->[1],
     $newhash{$_}->[0]);
             }              }
             if (untie(%hash)) {              if (untie(%hash)) {
  return 'ok';   return 'ok';
Line 4987  sub symbread { Line 4831  sub symbread {
         }          }
 # ---------------------------------------------------------- There was an entry  # ---------------------------------------------------------- There was an entry
         if ($syval) {          if ($syval) {
            unless ($syval=~/\_\d+$/) {      #unless ($syval=~/\_\d+$/) {
        unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) {   #unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) {
                   &appenv('request.ambiguous' => $thisfn);      #&appenv('request.ambiguous' => $thisfn);
   return $ENV{$cache_str}='';      #return $ENV{$cache_str}='';
                }       #}    
                $syval.=$1;   #$syval.=$1;
    }      #}
         } else {          } else {
 # ------------------------------------------------------- Was not in symb table  # ------------------------------------------------------- Was not in symb table
            if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',             if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
Line 5037  sub symbread { Line 4881  sub symbread {
            }             }
         }          }
         if ($syval) {          if ($syval) {
     return $ENV{$cache_str}=&symbclean($syval.'___'.$thisfn);      return $ENV{$cache_str}=$syval;
       #return $ENV{$cache_str}=&symbclean($syval.'___'.$thisfn);
         }          }
     }      }
     &appenv('request.ambiguous' => $thisfn);      &appenv('request.ambiguous' => $thisfn);
Line 5392  sub getfile { Line 5237  sub getfile {
   
 sub repcopy_userfile {  sub repcopy_userfile {
     my ($file)=@_;      my ($file)=@_;
   
     if ($file =~ m|^/*uploaded/|) { $file=&filelocation("",$file); }      if ($file =~ m|^/*uploaded/|) { $file=&filelocation("",$file); }
     if ($file =~ m|^/home/httpd/html/lonUsers/|) { return OK; }      if ($file =~ m|^/home/httpd/html/lonUsers/|) { return 'OK'; }
   
     my ($cdom,$cnum,$filename) =       my ($cdom,$cnum,$filename) = 
  ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+([^/]+)/+([^/]+)/+(.*)|);   ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+([^/]+)/+([^/]+)/+(.*)|);
     my ($info,$rtncode);      my ($info,$rtncode);
Line 5418  sub repcopy_userfile { Line 5261  sub repcopy_userfile {
     return -1;      return -1;
  }   }
  if ($info < $fileinfo[9]) {   if ($info < $fileinfo[9]) {
     return OK;      return 'OK';
  }   }
  $info = '';   $info = '';
  $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);   $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);
Line 5452  sub repcopy_userfile { Line 5295  sub repcopy_userfile {
     open(FILE,">$file");      open(FILE,">$file");
     print FILE $info;      print FILE $info;
     close(FILE);      close(FILE);
     return OK;      return 'OK';
 }  }
   
 sub tokenwrapper {  sub tokenwrapper {
Line 5503  sub readfile { Line 5346  sub readfile {
 }  }
   
 sub filelocation {  sub filelocation {
   my ($dir,$file) = @_;      my ($dir,$file) = @_;
   my $location;      my $location;
   $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces      $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces
   if ($file=~m:^/~:) { # is a contruction space reference      if ($file=~m:^/~:) { # is a contruction space reference
     $location = $file;          $location = $file;
     $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;          $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;
   } elsif ($file=~/^\/*uploaded/) { # is an uploaded file      } elsif ($file=~/^\/*uploaded/) { # is an uploaded file
       my ($udom,$uname,$filename)=          my ($udom,$uname,$filename)=
   ($file=~m|^/+uploaded/+([^/]+)/+([^/]+)/+(.*)$|);       ($file=~m|^/+uploaded/+([^/]+)/+([^/]+)/+(.*)$|);
       my $home=&homeserver($uname,$udom);          my $home=&homeserver($uname,$udom);
       my $is_me=0;          my $is_me=0;
       my @ids=&current_machine_ids();          my @ids=&current_machine_ids();
       foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }          foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }
       if ($is_me) {          if ($is_me) {
   $location=&Apache::loncommon::propath($udom,$uname).       $location=&Apache::loncommon::propath($udom,$uname).
       '/userfiles/'.$filename;         '/userfiles/'.$filename;
       } else {          } else {
   $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.     $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
       $udom.'/'.$uname.'/'.$filename;         $udom.'/'.$uname.'/'.$filename;
       }          }
   } else {  
     $file=~s/^\Q$perlvar{'lonDocRoot'}\E//;  
     $file=~s:^/res/:/:;  
     if ( !( $file =~ m:^/:) ) {  
       $location = $dir. '/'.$file;  
     } else {      } else {
       $location = '/home/httpd/html/res'.$file;          $file=~s/^\Q$perlvar{'lonDocRoot'}\E//;
           $file=~s:^/res/:/:;
           if ( !( $file =~ m:^/:) ) {
               $location = $dir. '/'.$file;
           } else {
               $location = '/home/httpd/html/res'.$file;
           }
     }      }
   }      $location=~s://+:/:g; # remove duplicate /
   $location=~s://+:/:g; # remove duplicate /      while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..
   while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..      while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./
   while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./      return $location;
   return $location;  
 }  }
   
 sub hreflocation {  sub hreflocation {
Line 5654  sub goodbye { Line 5497  sub goodbye {
    &logthis(sprintf("%-20s is %s",'%badServerCache',length(&freeze(\%badServerCache))));     &logthis(sprintf("%-20s is %s",'%badServerCache',length(&freeze(\%badServerCache))));
 #converted  #converted
 #   &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));  #   &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));
 #   &logthis(sprintf("%-20s is %s",'%homecache',length(&freeze(\%homecache))));     &logthis(sprintf("%-20s is %s",'%homecache',length(&freeze(\%homecache))));
 #   &logthis(sprintf("%-20s is %s",'%titlecache',length(&freeze(\%titlecache))));  #   &logthis(sprintf("%-20s is %s",'%titlecache',length(&freeze(\%titlecache))));
 #   &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&freeze(\%courseresdatacache))));  #   &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&freeze(\%courseresdatacache))));
 #1.1 only  #1.1 only
Line 5735  BEGIN { Line 5578  BEGIN {
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
        next if ($configline =~ /^(\#|\s*$)/);         next if ($configline =~ /^(\#|\s*$)/);
        chomp($configline);         chomp($configline);
        my ($id,$domain,$role,$name,$ip,$domdescr)=split(/:/,$configline);         my ($id,$domain,$role,$name)=split(/:/,$configline);
        if ($id && $domain && $role && $name && $ip) {         $name=~s/\s//g;
          if ($id && $domain && $role && $name) {
  $hostname{$id}=$name;   $hostname{$id}=$name;
  $hostdom{$id}=$domain;   $hostdom{$id}=$domain;
  $hostip{$id}=$ip;  
  $iphost{$ip}=$id;  
  if ($role eq 'library') { $libserv{$id}=$name; }   if ($role eq 'library') { $libserv{$id}=$name; }
        }         }
     }      }
     close($config);      close($config);
 }  }
   
   sub get_iphost {
       if (%iphost) { return %iphost; }
       foreach my $id (keys(%hostname)) {
    my $name=$hostname{$id};
    my $ip = gethostbyname($name);
    if (!$ip || length($ip) ne 4) {
       &logthis("Skipping host $id name $name no IP found\n");
       next;
    }
    $ip=inet_ntoa($ip);
    push(@{$iphost{$ip}},$id);
       }
       return %iphost;
   }
   
 # ------------------------------------------------------ Read spare server file  # ------------------------------------------------------ Read spare server file
 {  {
     open(my $config,"<$perlvar{'lonTabDir'}/spare.tab");      open(my $config,"<$perlvar{'lonTabDir'}/spare.tab");
Line 6255  subscribe($fname) : subscribe to a resou Line 6112  subscribe($fname) : subscribe to a resou
   
 repcopy($filename) : subscribes to the requested file, and attempts to  repcopy($filename) : subscribes to the requested file, and attempts to
 replicate from the owning library server, Might return  replicate from the owning library server, Might return
 HTTP_SERVICE_UNAVAILABLE, HTTP_NOT_FOUND, FORBIDDEN, OK, or  'HTTP_SERVICE_UNAVAILABLE', 'HTTP_NOT_FOUND', 'FORBIDDEN', 'OK', or
 HTTP_BAD_REQUEST, also attempts to grab the metadata for the  'HTTP_BAD_REQUEST', also attempts to grab the metadata for the
 resource. Expects the local filesystem pathname  resource. Expects the local filesystem pathname
 (/home/httpd/html/res/....)  (/home/httpd/html/res/....)
   
Removed from v.1.587.2.3.2.11  
changed lines
  Added in v.1.603

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