[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.522 and 1.541

version 1.522, 2004/07/16 17:56:01 version 1.541, 2004/09/15 20:08:34
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();  use Time::HiRes qw( gettimeofday tv_interval );
 my $readit;  my $readit;
   
 =pod  =pod
Line 821  sub getsection { Line 821  sub getsection {
 }  }
   
   
 my $disk_caching_disabled=1;  my $disk_caching_disabled=0;
   
 sub devalidate_cache {  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 ($disk_caching_disabled) { return; }      if (1 || $disk_caching_disabled) { return; }
     my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";      my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
     open(DB,"$filename.lock");      if (!-e $filename) { return; }
       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 881  sub do_cache { Line 882  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; }
     my $starttime=&Time::HiRes::time();      $do_save{$name}=$cache;
 #    &logthis("Saving :$name:$id");      if (!exists($do_save_item{$name})) { $do_save_item{$name}={} }
     my %hash;      $do_save_item{$name}->{$id}=1;
     my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";      return;
     open(DB,"$filename.lock");  }
     flock(DB,LOCK_EX);  
     if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {  sub save_cache {
  eval <<'EVALBLOCK';      if ($disk_caching_disabled) { return; }
     $hash{$id.'.time'}=$$cache{$id.'.time'};      my ($cache,$name,$id);
     $hash{$id}=freeze({'item'=>$$cache{$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}});
 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) {      }
     &logthis("Unable to tie hash (save cache item): $name ($!)");   } else {
     unlink($filename);      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));
     }      }
     untie(%hash);      undef(%do_save);
     flock(DB,LOCK_UN);      undef(%do_save_item);
     close(DB);  
 #    &logthis("save_cache_item $name took ".(&Time::HiRes::time()-$starttime));  
 }  }
   
 sub load_cache_item {  sub load_cache_item {
Line 918  sub load_cache_item { Line 940  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";
     open(DB,"$filename.lock");      if (!-e $filename) { return; }
       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 1047  sub currentversion { Line 1070  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 1066  sub subscribe { Line 1090  sub subscribe {
 sub repcopy {  sub repcopy {
     my $filename=shift;      my $filename=shift;
     $filename=~s/\/+/\//g;      $filename=~s/\/+/\//g;
     if ($filename=~/^\/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/userfiles/| or
    $filename=~m|^/*uploaded/|) { 
    return &repcopy_userfile($filename);
       }
       $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 1131  sub ssi_body { Line 1161  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 1267  sub process_coursefile { Line 1297  sub process_coursefile {
 # input: name of form element, coursedoc=1 means this is for the course  # input: name of form element, coursedoc=1 means this is for the course
 # output: url of file in userspace  # output: url of file in userspace
   
 sub userfileupload {  sub clean_filename {
     my ($formname,$coursedoc,$subdir)=@_;      my ($fname)=@_;
     if (!defined($subdir)) { $subdir='unknown'; }  
     my $fname=$ENV{'form.'.$formname.'.filename'};  
 # Replace Windows backslashes by forward slashes  # Replace Windows backslashes by forward slashes
     $fname=~s/\\/\//g;      $fname=~s/\\/\//g;
 # Get rid of everything but the actual filename  # Get rid of everything but the actual filename
Line 1279  sub userfileupload { Line 1307  sub userfileupload {
     $fname=~s/\s+/\_/g;      $fname=~s/\s+/\_/g;
 # Replace all other weird characters by nothing  # Replace all other weird characters by nothing
     $fname=~s/[^\w\.\-]//g;      $fname=~s/[^\w\.\-]//g;
   # Replace all .\d. sequences with _\d. so they no longer look like version
   # numbers
       $fname=~s/\.(\d+)(?=\.)/_$1/g;
       return $fname;
   }
   
   sub userfileupload {
       my ($formname,$coursedoc,$subdir)=@_;
       if (!defined($subdir)) { $subdir='unknown'; }
       my $fname=$ENV{'form.'.$formname.'.filename'};
       $fname=&clean_filename($fname);
 # See if there is anything left  # See if there is anything left
     unless ($fname) { return 'error: no uploaded file'; }      unless ($fname) { return 'error: no uploaded file'; }
     chop($ENV{'form.'.$formname});      chop($ENV{'form.'.$formname});
       if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) { #files uploaded to help request form are handled differently
           my $now = time;
           my $filepath = 'tmp/helprequests/'.$now;
           my @parts=split(/\//,$filepath);
           my $fullpath = $perlvar{'lonDaemons'};
           for (my $i=0;$i<@parts;$i++) {
               $fullpath .= '/'.$parts[$i];
               if ((-e $fullpath)!=1) {
                   mkdir($fullpath,0777);
               }
           }
           open(my $fh,'>'.$fullpath.'/'.$fname);
           print $fh $ENV{'form.'.$formname};
           close($fh);
           return $fullpath.'/'.$fname; 
       }
 # Create the directory if not present  # Create the directory if not present
     my $docuname='';      my $docuname='';
     my $docudom='';      my $docudom='';
Line 1356  sub removeuserfile { Line 1411  sub removeuserfile {
     return &reply("removeuserfile:$docudom/$docuname/$fname",$home);      return &reply("removeuserfile:$docudom/$docuname/$fname",$home);
 }  }
   
   sub mkdiruserfile {
       my ($docuname,$docudom,$dir)=@_;
       my $home=&homeserver($docuname,$docudom);
       return &reply("mkdiruserfile:".&escape("$docudom/$docuname/$dir"),$home);
   }
   
   sub renameuserfile {
       my ($docuname,$docudom,$old,$new)=@_;
       my $home=&homeserver($docuname,$docudom);
       return &reply("renameuserfile:$docudom:$docuname:".&escape("$old").':'.
     &escape("$new"),$home);
   }
   
 # ------------------------------------------------------------------------- Log  # ------------------------------------------------------------------------- Log
   
 sub log {  sub log {
Line 2575  sub put { Line 2643  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 2657  sub allowed { Line 2749  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 3077  sub fetch_enrollment_query { Line 3169  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 3096  sub fetch_enrollment_query { Line 3193  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 3609  sub revokecustomrole { Line 3710  sub revokecustomrole {
            $deleteflag);             $deleteflag);
 }  }
   
   # ------------------------------------------------------------ Disk usage
 # ------------------------------------------------------------ Portfolio Director Lister  sub diskusage {
 # returns listing of contents of user's /userfiles/portfolio/ directory      my ($udom,$uname,$directoryRoot)=@_;
 #       $directoryRoot =~ s/\/$//;
       my $listing=&reply('du:'.$directoryRoot,homeserver($uname,$udom));
 sub portfoliolist {  
     my ($currentPath, $currentFile) = @_;  
     my ($udom, $uname, $portfolioRoot);  
     $uname=$ENV{'user.name'};  
     $udom=$ENV{'user.domain'};  
     # really should interrogate the system for home directory information, but . . .  
     $portfolioRoot = '/home/httpd/lonUsers/'.$udom.'/';  
     $uname =~ /^(.?)(.?)(.?)/;  
     $portfolioRoot = $portfolioRoot.$1.'/'.$2.'/'.$3.'/'.$uname.'/userfiles/portfolio';  
     my $listing = &reply('ls:'.$portfolioRoot.$currentPath, &homeserver($uname,$udom));  
     return $listing;  
 }  
   
 sub portfoliomanage {  
   
 #FIXME please user the existing remove userfile function instead and  
 #add a userfilerename functions.  
 #FIXME uhome should never be an argument to any lonnet functions  
   
     # handles deleting and renaming files in user's userfiles/portfolio/ directory  
     #   
     my ($filename, $fileaction, $filenewname) = @_;  
     my ($udom, $uname, $uhome);  
     $uname=$ENV{'user.name'};  
     $udom=$ENV{'user.domain'};  
     $uhome=$ENV{'user.home'};  
     my $listing = reply('portfoliomanage:'.$uname.':'.$udom.':'.$filename.':'.$fileaction.':'.$filenewname, $uhome);  
     return $listing;      return $listing;
 }  }
   
Line 3978  sub EXT { Line 4052  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 3993  sub EXT { Line 4070  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 4035  sub EXT { Line 4112  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 4045  sub EXT { Line 4122  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 4148  sub metadata { Line 4225  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 4394  sub metadata_generate_part0 { Line 4473  sub metadata_generate_part0 {
 sub gettitle {  sub gettitle {
     my $urlsymb=shift;      my $urlsymb=shift;
     my $symb=&symbread($urlsymb);      my $symb=&symbread($urlsymb);
     unless ($symb) {      if ($symb) {
  unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; }   my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600);
         return &metadata($urlsymb,'title');    if (defined($cached)) { return $result; }
     }   my ($map,$resid,$url)=&decode_symb($symb);
     my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600);   my $title='';
     if (defined($cached)) { return $result; }   my %bighash;
     my ($map,$resid,$url)=&decode_symb($symb);   if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
     my $title='';   &GDBM_READER(),0640)) {
     my %bighash;      my $mapid=$bighash{'map_pc_'.&clutter($map)};
     if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',      $title=$bighash{'title_'.$mapid.'.'.$resid};
                             &GDBM_READER(),0640)) {      untie %bighash;
         my $mapid=$bighash{'map_pc_'.&clutter($map)};   }
         $title=$bighash{'title_'.$mapid.'.'.$resid};   $title=~s/\&colon\;/\:/gs;
         untie %bighash;   if ($title) {
     }      return &do_cache(\%titlecache,$symb,$title,'title');
     $title=~s/\&colon\;/\:/gs;   }
     if ($title) {   $urlsymb=$url;
         return &do_cache(\%titlecache,$symb,$title,'title');      }
     } else {      my $title=&metadata($urlsymb,'title');
  return &metadata($urlsymb,'title');      if (!$title) { $title=(split('/',$urlsymb))[-1]; }    
     }      return $title;
 }  }
           
 # ------------------------------------------------- Update symbolic store links  # ------------------------------------------------- Update symbolic store links
Line 4546  sub deversion { Line 4625  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'}) { return &symbclean($ENV{'request.symb'}); }          if ($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)) { return &symbclean($thisfn); }   if (&symbverify($thisfn,$1)) {
       $ENV{'request.symbread.cached'}=&symbclean($thisfn);
       return $ENV{'request.symbread.cached'};
    }
     }      }
     $thisfn=declutter($thisfn);      $thisfn=declutter($thisfn);
     my %hash;      my %hash;
Line 4574  sub symbread { Line 4662  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 4621  sub symbread { Line 4710  sub symbread {
            }             }
         }          }
         if ($syval) {          if ($syval) {
            return &symbclean($syval.'___'.$thisfn);       $ENV{'request.symbread.cached'}=&symbclean($syval.'___'.$thisfn);
       return $ENV{'request.symbread.cached'};
         }          }
     }      }
     &appenv('request.ambiguous' => $thisfn);      &appenv('request.ambiguous' => $thisfn);
       $ENV{'request.symbread.cached'}='';
     return '';      return '';
 }  }
   
Line 4886  sub receipt { Line 4977  sub receipt {
 # the local server.     # the local server.   
   
 sub getfile {  sub getfile {
     my ($file,$caller) = @_;      my ($file) = @_;
   
     if ($file !~ m|^/*uploaded/(\w+)/(\w+)/(.+)$|) {      if ($file =~ m|^/*uploaded/|) { $file=&filelocation("",$file); }
  # normal file from res space      &repcopy($file);
  &repcopy($file);      return &readfile($file);
         return &readfile($file);  }
     }  
   sub repcopy_userfile {
     my $info;      my ($file)=@_;
     my $cdom = $1;  
     my $cnum = $2;      if ($file =~ m|^/*uploaded/|) { $file=&filelocation("",$file); }
     my $filename = $3;      if ($file =~ m|^/home/httpd/html/lonUsers/|) { return OK; }
     my $path = $Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles';  
     my ($lwpresp,$rtncode);      my ($cdom,$cnum,$filename) = 
     my $localfile = $path.'/'.$cdom.'/'.$cnum.'/'.$filename;   ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+([^/]+)/+([^/]+)/+(.*)|);
     if (-e "$localfile") {      my ($info,$rtncode);
  my @fileinfo = stat($localfile);      my $uri="/uploaded/$cdom/$cnum/$filename";
  $lwpresp = &getuploaded('HEAD',$file,$cdom,$cnum,\$info,\$rtncode);      if (-e "$file") {
    my @fileinfo = stat($file);
    my $lwpresp = &getuploaded('HEAD',$uri,$cdom,$cnum,\$info,\$rtncode);
  if ($lwpresp ne 'ok') {   if ($lwpresp ne 'ok') {
     if ($rtncode eq '404') {      if ($rtncode eq '404') {
  unlink($localfile);   unlink($file);
     }      }
     #my $ua=new LWP::UserAgent;      #my $ua=new LWP::UserAgent;
     #my $request=new HTTP::Request('GET',&tokenwrapper($file));      #my $request=new HTTP::Request('GET',&tokenwrapper($uri));
     #my $response=$ua->request($request);      #my $response=$ua->request($request);
     #if ($response->is_success()) {      #if ($response->is_success()) {
  # return $response->content;   # return $response->content;
Line 4919  sub getfile { Line 5012  sub getfile {
     return -1;      return -1;
  }   }
  if ($info < $fileinfo[9]) {   if ($info < $fileinfo[9]) {
     return &readfile($localfile);      return OK;
  }   }
  $info = '';   $info = '';
  $lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode);   $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);
  if ($lwpresp ne 'ok') {   if ($lwpresp ne 'ok') {
     return -1;      return -1;
  }   }
     } else {      } else {
  $lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode);   my $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);
  if ($lwpresp ne 'ok') {   if ($lwpresp ne 'ok') {
     my $ua=new LWP::UserAgent;      my $ua=new LWP::UserAgent;
     my $request=new HTTP::Request('GET',&tokenwrapper($file));      my $request=new HTTP::Request('GET',&tokenwrapper($uri));
     my $response=$ua->request($request);      my $response=$ua->request($request);
     if ($response->is_success()) {      if ($response->is_success()) {
  return $response->content;   $info=$response->content;
     } else {      } else {
  return -1;   return -1;
     }      }
Line 4942  sub getfile { Line 5035  sub getfile {
  if ($filename =~ m|^(.+)/[^/]+$|) {   if ($filename =~ m|^(.+)/[^/]+$|) {
     push @parts, split(/\//,$1);      push @parts, split(/\//,$1);
  }   }
    my $path = $perlvar{'lonDocRoot'}.'/userfiles';
  foreach my $part (@parts) {   foreach my $part (@parts) {
     $path .= '/'.$part;      $path .= '/'.$part;
     if (!-e $path) {      if (!-e $path) {
Line 4949  sub getfile { Line 5043  sub getfile {
     }      }
  }   }
     }      }
     open (FILE,">$localfile");      open(FILE,">$file");
     print FILE $info;      print FILE $info;
     close(FILE);      close(FILE);
     if ($caller eq 'uploadrep') {      return OK;
  return 'ok';  
     }  
     return $info;  
 }  }
   
 sub tokenwrapper {  sub tokenwrapper {
Line 5011  sub filelocation { Line 5102  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;        my ($udom,$uname,$filename)=
     ($file=~m|^/+uploaded/+([^/]+)/+([^/]+)/+(.*)$|);
         my $home=&homeserver($uname,$udom);
         my $is_me=0;
         my @ids=&current_machine_ids();
         foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }
         if ($is_me) {
     $location=&Apache::loncommon::propath($udom,$uname).
         '/userfiles/'.$filename;
         } else {
     $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
         $udom.'/'.$uname.'/'.$filename;
         }
   } else {    } else {
     $file=~s/^\Q$perlvar{'lonDocRoot'}\E//;      $file=~s/^\Q$perlvar{'lonDocRoot'}\E//;
     $file=~s:^/res/:/:;      $file=~s:^/res/:/:;
Line 5207  BEGIN { Line 5310  BEGIN {
  $hostip{$id}=$ip;   $hostip{$id}=$ip;
  $iphost{$ip}=$id;   $iphost{$ip}=$id;
  if ($role eq 'library') { $libserv{$id}=$name; }   if ($role eq 'library') { $libserv{$id}=$name; }
        } else {  
  if ($configline) {  
    &logthis("Skipping hosts.tab line -$configline-");  
  }  
        }         }
     }      }
     close($config);      close($config);
Line 5902  put($namespace,$storehash,$udom,$uname) Line 6001  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.522  
changed lines
  Added in v.1.541

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