[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.523.2.3 and 1.529

version 1.523.2.3, 2004/09/15 20:44:05 version 1.529, 2004/08/23 19:34:01
Line 50  use Fcntl qw(:flock); Line 50  use Fcntl qw(:flock);
 use Apache::loncoursedata;  use Apache::loncoursedata;
 use Apache::lonlocal;  use Apache::lonlocal;
 use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw);  use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw);
 use Time::HiRes qw( gettimeofday tv_interval );  use Time::HiRes();
 my $readit;  my $readit;
   
 =pod  =pod
Line 827  sub devalidate_cache { Line 827  sub devalidate_cache {
     my ($cache,$id,$name) = @_;      my ($cache,$id,$name) = @_;
     delete $$cache{$id.'.time'};      delete $$cache{$id.'.time'};
     delete $$cache{$id};      delete $$cache{$id};
     if (1 || $disk_caching_disabled) { return; }      if ($disk_caching_disabled) { return; }
     my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";      my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
     if (!-e $filename) { return; }      open(DB,"$filename.lock");
     open(DB,">$filename.lock");  
     flock(DB,LOCK_EX);      flock(DB,LOCK_EX);
     my %hash;      my %hash;
     if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {      if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {
Line 882  sub do_cache { Line 881  sub do_cache {
     $$cache{$id};      $$cache{$id};
 }  }
   
 my %do_save_item;  
 my %do_save;  
 sub save_cache_item {  sub save_cache_item {
     my ($cache,$name,$id)=@_;      my ($cache,$name,$id)=@_;
     if ($disk_caching_disabled) { return; }      if ($disk_caching_disabled) { return; }
     $do_save{$name}=$cache;      my $starttime=&Time::HiRes::time();
     if (!exists($do_save_item{$name})) { $do_save_item{$name}={} }  #    &logthis("Saving :$name:$id");
     $do_save_item{$name}->{$id}=1;      my %hash;
     return;      my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
 }      open(DB,"$filename.lock");
       flock(DB,LOCK_EX);
 sub save_cache {      if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {
     if ($disk_caching_disabled) { return; }   eval <<'EVALBLOCK';
     my ($cache,$name,$id);      $hash{$id.'.time'}=$$cache{$id.'.time'};
     foreach $name (keys(%do_save)) {      $hash{$id}=freeze({'item'=>$$cache{$id}});
  $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}});  
 EVALBLOCK  EVALBLOCK
                 if ($@) {          if ($@) {
     &logthis("<font color='red'>save_cache blew up :$@:$name</font>");      &logthis("<font color='red'>save_cache blew up :$@:$name</font>");
     unlink($filename);      unlink($filename);
     last;   }
  }      } else {
     }   if (-e $filename) {
  } else {      &logthis("Unable to tie hash (save cache item): $name ($!)");
     if (-e $filename) {      unlink($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);      untie(%hash);
     undef(%do_save_item);      flock(DB,LOCK_UN);
       close(DB);
   #    &logthis("save_cache_item $name took ".(&Time::HiRes::time()-$starttime));
 }  }
   
 sub load_cache_item {  sub load_cache_item {
Line 940  sub load_cache_item { Line 918  sub load_cache_item {
 #    &logthis("Before Loading $name  for $id size is ".scalar(%$cache));  #    &logthis("Before Loading $name  for $id size is ".scalar(%$cache));
     my %hash;      my %hash;
     my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";      my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
     if (!-e $filename) { return; }      open(DB,"$filename.lock");
     open(DB,">$filename.lock");  
     flock(DB,LOCK_SH);      flock(DB,LOCK_SH);
     if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) {      if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) {
  eval <<'EVALBLOCK';   eval <<'EVALBLOCK';
Line 1070  sub currentversion { Line 1047  sub currentversion {
 sub subscribe {  sub subscribe {
     my $fname=shift;      my $fname=shift;
     if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return ''; }      if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return ''; }
     $fname=~s/[\n\r]//g;  
     my $author=$fname;      my $author=$fname;
     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;      $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
     my ($udom,$uname)=split(/\//,$author);      my ($udom,$uname)=split(/\//,$author);
Line 1091  sub repcopy { Line 1067  sub repcopy {
     my $filename=shift;      my $filename=shift;
     $filename=~s/\/+/\//g;      $filename=~s/\/+/\//g;
     if ($filename=~/^\/home\/httpd\/html\/adm\//) { return OK; }      if ($filename=~/^\/home\/httpd\/html\/adm\//) { return OK; }
     $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);
Line 1156  sub ssi_body { Line 1131  sub ssi_body {
     my ($filelink,%form)=@_;      my ($filelink,%form)=@_;
     my $output=($filelink=~/^http\:/?&externalssi($filelink):      my $output=($filelink=~/^http\:/?&externalssi($filelink):
                                      &ssi($filelink,%form));                                       &ssi($filelink,%form));
     $output=~s/^.*?\<body[^\>]*\>//si;  
     $output=~s/(.*)\<\/body\s*\>.*?$/$1/si;  
     $output=~      $output=~
             s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs;              s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs;
       $output=~s/^.*?\<body[^\>]*\>//si;
       $output=~s/(.*)\<\/body\s*\>.*?$/$1/si;
     return $output;      return $output;
 }  }
   
Line 2616  sub put { Line 2591  sub put {
    return &reply("put:$udomain:$uname:$namespace:$items",$uhome);     return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
 }  }
   
   # ---------------------------------------------------------- putstore interface
                                                                                        
   sub putstore {
      my ($namespace,$storehash,$udomain,$uname)=@_;
      if (!$udomain) { $udomain=$ENV{'user.domain'}; }
      if (!$uname) { $uname=$ENV{'user.name'}; }
      my $uhome=&homeserver($uname,$udomain);
      my $items='';
      my %allitems = ();
      foreach (keys %$storehash) {
          if ($_ =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) {
              my $key = $1.':keys:'.$2;
              $allitems{$key} .= $3.':';
          }
          $items.=$_.'='.&escape($$storehash{$_}).'&';
      }
      foreach (keys %allitems) {
          $allitems{$_} =~ s/\:$//;
          $items.= $_.'='.$allitems{$_}.'&';
      }
      $items=~s/\&$//;
      return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
   }
   
 # ------------------------------------------------------ critical put interface  # ------------------------------------------------------ critical put interface
   
 sub cput {  sub cput {
Line 2698  sub allowed { Line 2697  sub allowed {
   
     if (defined($ENV{'allowed.'.$priv})) { return $ENV{'allowed.'.$priv}; }      if (defined($ENV{'allowed.'.$priv})) { return $ENV{'allowed.'.$priv}; }
 # Free bre access to adm and meta resources  # Free bre access to adm and meta resources
       if (((($uri=~/^adm\//) && ($uri !~ m|/bulletinboard$|)) 
     if ((($uri=~/^adm\//) || ($uri=~/\.meta$/)) && ($priv eq 'bre')) {   || ($uri=~/\.meta$/)) && ($priv eq 'bre')) {
  return 'F';   return 'F';
     }      }
   
Line 3118  sub fetch_enrollment_query { Line 3117  sub fetch_enrollment_query {
     $cmd = &escape($cmd);      $cmd = &escape($cmd);
     my $query = 'fetchenrollment';      my $query = 'fetchenrollment';
     my $queryid=&reply("querysend:".$query.':'.$dom.':'.$ENV{'user.name'}.':'.$cmd,$homeserver);      my $queryid=&reply("querysend:".$query.':'.$dom.':'.$ENV{'user.name'}.':'.$cmd,$homeserver);
     unless ($queryid=~/^\Q$host\E\_/) { return 'error: '.$queryid; }      unless ($queryid=~/^\Q$host\E\_/) { 
           &logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum); 
           return 'error: '.$queryid;
       }
     my $reply = &get_query_reply($queryid);      my $reply = &get_query_reply($queryid);
     unless ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {      if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
           &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$ENV{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum);
       } else {
         my @responses = split/:/,$reply;          my @responses = split/:/,$reply;
         if ($homeserver eq $perlvar{'lonHostID'}) {          if ($homeserver eq $perlvar{'lonHostID'}) {
             foreach (@responses) {              foreach (@responses) {
Line 3137  sub fetch_enrollment_query { Line 3141  sub fetch_enrollment_query {
                         my $filename = $dom.'_'.$key.'_'.$_.'_classlist.xml';                          my $filename = $dom.'_'.$key.'_'.$_.'_classlist.xml';
                         my $destname = $pathname.'/'.$filename;                          my $destname = $pathname.'/'.$filename;
                         my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver);                          my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver);
                         unless ($xml_classlist =~ /^error/) {                          if ($xml_classlist =~ /^error/) {
                               &logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum);
                           } else {
                             if ( open(FILE,">$destname") ) {                              if ( open(FILE,">$destname") ) {
                                 print FILE &unescape($xml_classlist);                                  print FILE &unescape($xml_classlist);
                                 close(FILE);                                  close(FILE);
                               } else {
                                   &logthis('fetch_enrollment_query - error opening classlist file '.$destname.' '.$context.' '.$cnum);
                             }                              }
                         }                          }
                     }                      }
Line 4019  sub EXT { Line 4027  sub EXT {
   
  my $section;   my $section;
  if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) {   if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) {
     if (!$symbparm) { $symbparm=&symbread(); }  
  }  
  if ($symbparm && defined($courseid) &&   
     $courseid eq $ENV{'request.course.id'}) {  
   
     #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;      #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
   
 # ----------------------------------------------------- Cascading lookup scheme  # ----------------------------------------------------- Cascading lookup scheme
       if (!$symbparm) { $symbparm=&symbread(); }
     my $symbp=$symbparm;      my $symbp=$symbparm;
     my $mapp=(&decode_symb($symbp))[0];      my $mapp=(&decode_symb($symbp))[0];
   
Line 4037  sub EXT { Line 4042  sub EXT {
  ($ENV{'user.domain'} eq $udom)) {   ($ENV{'user.domain'} eq $udom)) {
  $section=$ENV{'request.course.sec'};   $section=$ENV{'request.course.sec'};
     } else {      } else {
  if (! defined($usection)) {                  if (! defined($usection)) {
     $section=&usection($udom,$uname,$courseid);                      $section=&usection($udom,$uname,$courseid);
  } else {                  } else {
     $section = $usection;                      $section = $usection;
  }                  }
     }      }
   
     my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;      my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
Line 4079  sub EXT { Line 4084  sub EXT {
  $uname." at ".$udom.": ".   $uname." at ".$udom.": ".
  $tmp."</font>");   $tmp."</font>");
     } elsif ($tmp=~/error: 2 /) {      } elsif ($tmp=~/error: 2 /) {
  &EXT_cache_set($udom,$uname);                          &EXT_cache_set($udom,$uname);
     } elsif ($tmp =~ /^(con_lost|no_such_host)/) {      } elsif ($tmp =~ /^(con_lost|no_such_host)/) {
  return $tmp;   return $tmp;
     }      }
Line 4089  sub EXT { Line 4094  sub EXT {
 # -------------------------------------------------------- second, check course  # -------------------------------------------------------- second, check 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,$courselevelm,
     $courselevel));     $courselevel));
     if (defined($coursereply)) { return $coursereply; }      if (defined($coursereply)) { return $coursereply; }
   
 # ------------------------------------------------------ third, check map parms  # ------------------------------------------------------ third, check map parms
Line 4192  sub metadata { Line 4197  sub metadata {
     my ($uri,$what,$liburi,$prefix,$depthcount)=@_;      my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
     $uri=&declutter($uri);      $uri=&declutter($uri);
     # if it is a non metadata possible uri return quickly      # if it is a non metadata possible uri return quickly
     if (($uri eq '') || (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|)) ||      if (($uri eq '') || 
    (($uri =~ m|^/*adm/|) && 
        ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) ||
         ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||          ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||
  ($uri =~ m|home/[^/]+/public_html/|)) {   ($uri =~ m|home/[^/]+/public_html/|)) {
  return undef;   return undef;
Line 4590  sub deversion { Line 4597  sub deversion {
   
 sub symbread {  sub symbread {
     my ($thisfn,$donotrecurse)=@_;      my ($thisfn,$donotrecurse)=@_;
     if (defined($ENV{'request.symbread.cached'})) {  
  return $ENV{'request.symbread.cached'};  
     }  
 # no filename provided? try from environment  # no filename provided? try from environment
     unless ($thisfn) {      unless ($thisfn) {
         if ($ENV{'request.symb'}) {          if ($ENV{'request.symb'}) { return &symbclean($ENV{'request.symb'}); }
     $ENV{'request.symbread.cached'}=&symbclean($ENV{'request.symb'});  
     return $ENV{'request.symbread.cached'};  
  }  
  $thisfn=$ENV{'request.filename'};   $thisfn=$ENV{'request.filename'};
     }      }
 # is that filename actually a symb? Verify, clean, and return  # is that filename actually a symb? Verify, clean, and return
     if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) {      if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) {
  if (&symbverify($thisfn,$1)) {   if (&symbverify($thisfn,$1)) { return &symbclean($thisfn); }
     $ENV{'request.symbread.cached'}=&symbclean($thisfn);  
     return $ENV{'request.symbread.cached'};  
  }  
     }      }
     $thisfn=declutter($thisfn);      $thisfn=declutter($thisfn);
     my %hash;      my %hash;
Line 4627  sub symbread { Line 4625  sub symbread {
            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);
   $ENV{'request.symbread.cached'}='';  
                   return '';                    return '';
                }                     }    
                $syval.=$1;                 $syval.=$1;
Line 4675  sub symbread { Line 4672  sub symbread {
            }             }
         }          }
         if ($syval) {          if ($syval) {
     $ENV{'request.symbread.cached'}=&symbclean($syval.'___'.$thisfn);             return &symbclean($syval.'___'.$thisfn); 
     return $ENV{'request.symbread.cached'};  
         }          }
     }      }
     &appenv('request.ambiguous' => $thisfn);      &appenv('request.ambiguous' => $thisfn);
     $ENV{'request.symbread.cached'}='';  
     return '';      return '';
 }  }
   
Line 5067  sub filelocation { Line 5062  sub filelocation {
     $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
     $location=$file;        if ($file=~/^\/uploaded\/([^\/]+)\/([^\/]+)\/(\/)?simplepage\/([^\/]+)$/) {
     $location=&Apache::loncommon::propath($1,$2).'/userfiles/simplepage/'.$4;
     if (not -e $location) {
         $file=~/^\/uploaded\/(.*)$/;
         $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.$1;
     }
         } elsif ($file=~/^\/uploaded\/([^\/]+)\/([^\/]+)\/aboutme\/([^\/]+)$/) {
     $location=&Apache::loncommon::propath($1,$2).'/userfiles/aboutme/'.$3;
            if (not -e $location) {
        $file=~/^\/uploaded\/(.*)$/;
        $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.$1;
            }
         } else {
     $location=$file;
         }
   } else {    } else {
     $file=~s/^\Q$perlvar{'lonDocRoot'}\E//;      $file=~s/^\Q$perlvar{'lonDocRoot'}\E//;
     $file=~s:^/res/:/:;      $file=~s:^/res/:/:;
Line 5958  put($namespace,$storehash,$udom,$uname) Line 5967  put($namespace,$storehash,$udom,$uname)
   
 =item *  =item *
   
   putstore($namespace,$storehash,$udomain,$uname) : stores hash in namesp
   keys used in storehash include version information (e.g., 1:$symb:message etc.) as
   used in records written by &store and retrieved by &restore.  This function 
   was created for use in editing discussion posts, without incrementing the
   version number included in the key for a particular post. The colon 
   separated list of attribute names (e.g., the value associated with the key 
   1:keys:$symb) is also generated and passed in the ampersand separated 
   items sent to lonnet::reply().  
   
   =item *
   
 cput($namespace,$storehash,$udom,$uname) : critical put  cput($namespace,$storehash,$udom,$uname) : critical put
 ($udom and $uname are optional)  ($udom and $uname are optional)
   
Removed from v.1.523.2.3  
changed lines
  Added in v.1.529

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