[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.509 and 1.542

version 1.509, 2004/06/10 22:15:53 version 1.542, 2004/09/17 02:40:35
Line 38  use vars Line 38  use vars
 qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom   qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom 
    %libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache     %libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache
    %courselogs %accesshash %userrolehash $processmarker $dumpcount      %courselogs %accesshash %userrolehash $processmarker $dumpcount 
    %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache      %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseresdatacache 
    %userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def      %userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def 
    %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir);     %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir);
   
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 856  sub is_cached { Line 857  sub is_cached {
     my ($cache,$id,$name,$time) = @_;      my ($cache,$id,$name,$time) = @_;
     if (!$time) { $time=300; }      if (!$time) { $time=300; }
     if (!exists($$cache{$id.'.time'})) {      if (!exists($$cache{$id.'.time'})) {
  &load_cache_item($cache,$name,$id);   &load_cache_item($cache,$name,$id,$time);
     }      }
     if (!exists($$cache{$id.'.time'})) {      if (!exists($$cache{$id.'.time'})) {
 # &logthis("Didn't find $id");  # &logthis("Didn't find $id");
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 {
     my ($cache,$name,$id)=@_;      my ($cache,$name,$id,$time)=@_;
     if ($disk_caching_disabled) { return; }      if ($disk_caching_disabled) { return; }
     my $starttime=&Time::HiRes::time();      my $starttime=&Time::HiRes::time();
 #    &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 935  sub load_cache_item { Line 958  sub load_cache_item {
  }   }
 #    &logthis("Initial load: $count");  #    &logthis("Initial load: $count");
     } else {      } else {
  my $hashref=thaw($hash{$id});   if (($$cache{$id.'.time'}+$time) < time) {
  $$cache{$id}=$hashref->{'item'};      $$cache{$id.'.time'}=$hash{$id.'.time'};
  $$cache{$id.'.time'}=$hash{$id.'.time'};      my $hashref=thaw($hash{$id});
       $$cache{$id}=$hashref->{'item'};
    }
     }      }
 EVALBLOCK  EVALBLOCK
         if ($@) {          if ($@) {
Line 1047  sub currentversion { Line 1072  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 1092  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 1163  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 1299  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 1309  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 1413  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 1395  sub flushcourselogs { Line 1465  sub flushcourselogs {
         }          }
         if ($courseidbuffer{$coursehombuf{$crsid}}) {          if ($courseidbuffer{$coursehombuf{$crsid}}) {
            $courseidbuffer{$coursehombuf{$crsid}}.='&'.             $courseidbuffer{$coursehombuf{$crsid}}.='&'.
  &escape($crsid).'='.&escape($coursedescrbuf{$crsid});   &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
                            '='.&escape($courseinstcodebuf{$crsid});
         } else {          } else {
            $courseidbuffer{$coursehombuf{$crsid}}=             $courseidbuffer{$coursehombuf{$crsid}}=
  &escape($crsid).'='.&escape($coursedescrbuf{$crsid});   &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
                            '='.&escape($courseinstcodebuf{$crsid});
         }              }    
     }      }
 #  #
Line 1472  sub courselog { Line 1544  sub courselog {
        $ENV{'course.'.$ENV{'request.course.id'}.'.home'};         $ENV{'course.'.$ENV{'request.course.id'}.'.home'};
     $coursedescrbuf{$ENV{'request.course.id'}}=      $coursedescrbuf{$ENV{'request.course.id'}}=
        $ENV{'course.'.$ENV{'request.course.id'}.'.description'};         $ENV{'course.'.$ENV{'request.course.id'}.'.description'};
       $courseinstcodebuf{$ENV{'request.course.id'}}=
          $ENV{'course.'.$ENV{'request.course.id'}.'.internal.coursecode'};
     if (defined $courselogs{$ENV{'request.course.id'}}) {      if (defined $courselogs{$ENV{'request.course.id'}}) {
  $courselogs{$ENV{'request.course.id'}}.='&'.$what;   $courselogs{$ENV{'request.course.id'}}.='&'.$what;
     } else {      } else {
Line 1596  sub getannounce { Line 1670  sub getannounce {
  if ($announcement=~/\w/) {    if ($announcement=~/\w/) { 
     return       return 
    '<table bgcolor="#FF5555" cellpadding="5" cellspacing="3">'.     '<table bgcolor="#FF5555" cellpadding="5" cellspacing="3">'.
    '<tr><td bgcolor="#FFFFFF"><pre>'.$announcement.'</pre></td></tr></table>';      '<tr><td bgcolor="#FFFFFF"><tt>'.$announcement.'</tt></td></tr></table>'; 
  } else {   } else {
     return '';      return '';
  }   }
Line 1615  sub courseidput { Line 1689  sub courseidput {
 }  }
   
 sub courseiddump {  sub courseiddump {
     my ($domfilter,$descfilter,$sincefilter,$hostid)=@_;      my ($domfilter,$descfilter,$sincefilter,$hostidflag,$hostidref)=@_;
     my %returnhash=();      my %returnhash=();
     unless ($domfilter) { $domfilter=''; }      unless ($domfilter) { $domfilter=''; }
     foreach my $tryserver (keys %libserv) {      foreach my $tryserver (keys %libserv) {
         if (($hostid && $tryserver eq $hostid) || (!$hostid)) {          if ( ($hostidflag == 1 && grep/^$tryserver$/,@{$hostidref}) || (!defined($hostidflag)) ) {
     if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) {      if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) {
         foreach (          foreach (
                  split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.                   split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.
Line 1627  sub courseiddump { Line 1701  sub courseiddump {
                                $tryserver))) {                                 $tryserver))) {
     my ($key,$value)=split(/\=/,$_);      my ($key,$value)=split(/\=/,$_);
                     if (($key) && ($value)) {                      if (($key) && ($value)) {
         $returnhash{&unescape($key)}=&unescape($value);          $returnhash{&unescape($key)}=$value;
                     }                      }
                 }                  }
             }              }
Line 2571  sub put { Line 2645  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 2653  sub allowed { Line 2751  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 3057  sub log_query { Line 3155  sub log_query {
 # ------- Request retrieval of institutional classlists for course(s)  # ------- Request retrieval of institutional classlists for course(s)
   
 sub fetch_enrollment_query {  sub fetch_enrollment_query {
     my ($context,$affiliatesref,$replyref,$cnum,$dom) = @_;      my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_;
     my $homeserver;      my $homeserver;
     if ($context eq 'automated') {      if ($context eq 'automated') {
         $homeserver = $perlvar{'lonHostID'};          $homeserver = $perlvar{'lonHostID'};
Line 3073  sub fetch_enrollment_query { Line 3171  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/) ) {
         unless ($homeserver eq $perlvar{'lonHostID'}) {          &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$ENV{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum);
             my @responses = split/:/,$reply;      } else {
           my @responses = split/:/,$reply;
           if ($homeserver eq $perlvar{'lonHostID'}) {
               foreach (@responses) {
                   my ($key,$value) = split/=/,$_;
                   $$replyref{$key} = $value;
               }
           } else {
             my $pathname = $perlvar{'lonDaemons'}.'/tmp';              my $pathname = $perlvar{'lonDaemons'}.'/tmp';
             foreach (@responses) {              foreach (@responses) {
                 my ($key,$value) = split/=/,$_;                  my ($key,$value) = split/=/,$_;
Line 3087  sub fetch_enrollment_query { Line 3195  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 3151  sub userlog_query { Line 3263  sub userlog_query {
 sub auto_run {  sub auto_run {
     my ($cnum,$cdom) = @_;      my ($cnum,$cdom) = @_;
     my $homeserver = &homeserver($cnum,$cdom);      my $homeserver = &homeserver($cnum,$cdom);
     my $response = &reply('autorun',$homeserver);      my $response = &reply('autorun:'.$cdom,$homeserver);
     return $response;      return $response;
 }  }
                                                                                                                                                                         
Line 3159  sub auto_get_sections { Line 3271  sub auto_get_sections {
     my ($cnum,$cdom,$inst_coursecode) = @_;      my ($cnum,$cdom,$inst_coursecode) = @_;
     my $homeserver = &homeserver($cnum,$cdom);      my $homeserver = &homeserver($cnum,$cdom);
     my @secs = ();      my @secs = ();
     my $response=&unescape(&reply('autogetsections:'.$inst_coursecode,$homeserver));      my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));
     unless ($response eq 'refused') {      unless ($response eq 'refused') {
         @secs = split/:/,$response;          @secs = split/:/,$response;
     }      }
Line 3169  sub auto_get_sections { Line 3281  sub auto_get_sections {
 sub auto_new_course {  sub auto_new_course {
     my ($cnum,$cdom,$inst_course_id,$owner) = @_;      my ($cnum,$cdom,$inst_course_id,$owner) = @_;
     my $homeserver = &homeserver($cnum,$cdom);      my $homeserver = &homeserver($cnum,$cdom);
     my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner,$homeserver));      my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner.':'.$cdom,$homeserver));
     return $response;      return $response;
 }  }
                                                                                                                                                                         
 sub auto_validate_courseID {  sub auto_validate_courseID {
     my ($cnum,$cdom,$inst_course_id) = @_;      my ($cnum,$cdom,$inst_course_id) = @_;
     my $homeserver = &homeserver($cnum,$cdom);      my $homeserver = &homeserver($cnum,$cdom);
     my $response=&unescape(&reply('autovalidatecourse:'.$inst_course_id,$homeserver));      my $response=&unescape(&reply('autovalidatecourse:'.$inst_course_id.':'.$cdom,$homeserver));
     return $response;      return $response;
 }  }
                                                                                                                                                                         
Line 3185  sub auto_create_password { Line 3297  sub auto_create_password {
     my $homeserver = &homeserver($cnum,$cdom);       my $homeserver = &homeserver($cnum,$cdom); 
     my $create_passwd = 0;      my $create_passwd = 0;
     my $authchk = '';      my $authchk = '';
     my $response=&unescape(&reply('autocreatepassword:'.$authparam,$homeserver));      my $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver));
     if ($response eq 'refused') {      if ($response eq 'refused') {
         $authchk = 'refused';          $authchk = 'refused';
     } else {      } else {
Line 3194  sub auto_create_password { Line 3306  sub auto_create_password {
     return ($authparam,$create_passwd,$authchk);      return ($authparam,$create_passwd,$authchk);
 }  }
   
   sub auto_instcode_format {
       my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,$cat_order) = @_;
       my $courses = '';
       my $homeserver;
       if ($caller eq 'global') {
           $homeserver = $perlvar{'lonHostID'};
       } else {
           $homeserver = &homeserver($caller,$codedom);
       }
       my $host=$hostname{$homeserver};
       foreach (keys %{$instcodes}) {
           $courses .= &escape($_).'='.&escape($$instcodes{$_}).'&';
       }
       chop($courses);
       my $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$homeserver);
       unless ($response =~ /(con_lost|error|no_such_host|refused)/) {
           my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = split/:/,$response;
           %{$codes} = &str2hash($codes_str);
           @{$codetitles} = &str2array($codetitles_str);
           %{$cat_titles} = &str2hash($cat_titles_str);
           %{$cat_order} = &str2hash($cat_order_str);
           return 'ok';
       }
       return $response;
   }
   
 # ------------------------------------------------------------------ Plain Text  # ------------------------------------------------------------------ Plain Text
   
 sub plaintext {  sub plaintext {
Line 3384  sub modifyuser { Line 3522  sub modifyuser {
   
 sub modifystudent {  sub modifystudent {
     my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,      my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
         $end,$start,$forceid,$desiredhome,$email,$type,$cid)=@_;          $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid)=@_;
     if (!$cid) {      if (!$cid) {
  unless ($cid=$ENV{'request.course.id'}) {   unless ($cid=$ENV{'request.course.id'}) {
     return 'not_in_class';      return 'not_in_class';
Line 3399  sub modifystudent { Line 3537  sub modifystudent {
     # students environment      # students environment
     $uid = undef if (!$forceid);      $uid = undef if (!$forceid);
     $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,      $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
  $gene,$usec,$end,$start,$type,$cid);   $gene,$usec,$end,$start,$type,$locktype,$cid);
     return $reply;      return $reply;
 }  }
   
 sub modify_student_enrollment {  sub modify_student_enrollment {
     my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,      my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid) = @_;
  $cid) = @_;  
     my ($cdom,$cnum,$chome);      my ($cdom,$cnum,$chome);
     if (!$cid) {      if (!$cid) {
  unless ($cid=$ENV{'request.course.id'}) {   unless ($cid=$ENV{'request.course.id'}) {
Line 3451  sub modify_student_enrollment { Line 3588  sub modify_student_enrollment {
                                                            $first,$middle);                                                             $first,$middle);
     my $reply=cput('classlist',      my $reply=cput('classlist',
    {"$uname:$udom" =>      {"$uname:$udom" => 
  join(':',$end,$start,$uid,$usec,$fullname,$type) },   join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) },
    $cdom,$cnum);     $cdom,$cnum);
     unless (($reply eq 'ok') || ($reply eq 'delayed')) {      unless (($reply eq 'ok') || ($reply eq 'delayed')) {
  return 'error: '.$reply;   return 'error: '.$reply;
Line 3487  sub writecoursepref { Line 3624  sub writecoursepref {
 # ---------------------------------------------------------- Make/modify course  # ---------------------------------------------------------- Make/modify course
   
 sub createcourse {  sub createcourse {
     my ($udom,$description,$url,$course_server,$nonstandard)=@_;      my ($udom,$description,$url,$course_server,$nonstandard,$inst_code)=@_;
     $url=&declutter($url);      $url=&declutter($url);
     my $cid='';      my $cid='';
     unless (&allowed('ccc',$udom)) {      unless (&allowed('ccc',$udom)) {
Line 3520  sub createcourse { Line 3657  sub createcourse {
  return 'error: no such course';   return 'error: no such course';
     }      }
 # ----------------------------------------------------------------- Course made  # ----------------------------------------------------------------- Course made
 # log existance  # log existence
     &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description),      &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description).
                  $uhome);                   '='.&escape($inst_code),$uhome);
     &flushcourselogs();      &flushcourselogs();
 # set toplevel url  # set toplevel url
     my $topurl=$url;      my $topurl=$url;
Line 3575  sub revokecustomrole { Line 3712  sub revokecustomrole {
            $deleteflag);             $deleteflag);
 }  }
   
   # ------------------------------------------------------------ Disk usage
   sub diskusage {
       my ($udom,$uname,$directoryRoot)=@_;
       $directoryRoot =~ s/\/$//;
       my $listing=&reply('du:'.$directoryRoot,homeserver($uname,$udom));
       return $listing;
   }
   
   
 # ------------------------------------------------------------ Directory lister  # ------------------------------------------------------------ Directory lister
   
 sub dirlist {  sub dirlist {
Line 3908  sub EXT { Line 4054  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 3923  sub EXT { Line 4072  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 3965  sub EXT { Line 4114  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 3975  sub EXT { Line 4124  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 4078  sub metadata { Line 4227  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 4324  sub metadata_generate_part0 { Line 4475  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 4370  sub symblist { Line 4521  sub symblist {
 # --------------------------------------------------------------- Verify a symb  # --------------------------------------------------------------- Verify a symb
   
 sub symbverify {  sub symbverify {
     my ($symb,$thisfn)=@_;      my ($symb,$thisurl)=@_;
       my $thisfn=$thisurl;
   # wrapper not part of symbs
       $thisfn=~s/^\/adm\/wrapper//;
     $thisfn=&declutter($thisfn);      $thisfn=&declutter($thisfn);
 # direct jump to resource in page or to a sequence - will construct own symbs  # direct jump to resource in page or to a sequence - will construct own symbs
     if ($thisfn=~/\.(page|sequence)$/) { return 1; }      if ($thisfn=~/\.(page|sequence)$/) { return 1; }
Line 4380  sub symbverify { Line 4534  sub symbverify {
     unless ($url eq $thisfn) { return 0; }      unless ($url eq $thisfn) { return 0; }
   
     $symb=&symbclean($symb);      $symb=&symbclean($symb);
       $thisurl=&deversion($thisurl);
     $thisfn=&deversion($thisfn);      $thisfn=&deversion($thisfn);
   
     my %bighash;      my %bighash;
Line 4387  sub symbverify { Line 4542  sub symbverify {
   
     if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',      if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
                             &GDBM_READER(),0640)) {                              &GDBM_READER(),0640)) {
         my $ids=$bighash{'ids_'.&clutter($thisfn)};          my $ids=$bighash{'ids_'.&clutter($thisurl)};
         unless ($ids) {           unless ($ids) { 
            $ids=$bighash{'ids_/'.$thisfn};             $ids=$bighash{'ids_/'.$thisurl};
         }          }
         if ($ids) {          if ($ids) {
 # ------------------------------------------------------------------- Has ID(s)  # ------------------------------------------------------------------- Has ID(s)
Line 4420  sub symbclean { Line 4575  sub symbclean {
   
 # remove wrapper  # remove wrapper
   
     $symb=~s/(\_\_\_\d+\_\_\_)adm\/wrapper\//$1/;      $symb=~s/(\_\_\_\d+\_\_\_)adm\/wrapper\/(res\/)*/$1/;
     return $symb;      return $symb;
 }  }
   
Line 4472  sub deversion { Line 4627  sub deversion {
   
 sub symbread {  sub symbread {
     my ($thisfn,$donotrecurse)=@_;      my ($thisfn,$donotrecurse)=@_;
       my $cache_str='request.symbread.cached.'.$thisfn;
       if (defined($ENV{$cache_str})) { return $ENV{$cache_str}; }
 # 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'}) {
       return $ENV{$cache_str}=&symbclean($ENV{'request.symb'});
    }
  $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)) {
       return $ENV{$cache_str}=&symbclean($thisfn);
    }
     }      }
     $thisfn=declutter($thisfn);      $thisfn=declutter($thisfn);
     my %hash;      my %hash;
Line 4500  sub symbread { Line 4661  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);
                   return '';    return $ENV{$cache_str}='';
                }                     }    
                $syval.=$1;                 $syval.=$1;
    }     }
Line 4547  sub symbread { Line 4708  sub symbread {
            }             }
         }          }
         if ($syval) {          if ($syval) {
            return &symbclean($syval.'___'.$thisfn);       return $ENV{$cache_str}=&symbclean($syval.'___'.$thisfn);
         }          }
     }      }
     &appenv('request.ambiguous' => $thisfn);      &appenv('request.ambiguous' => $thisfn);
     return '';      return $ENV{$cache_str}='';
 }  }
   
 # ---------------------------------------------------------- Return random seed  # ---------------------------------------------------------- Return random seed
Line 4812  sub receipt { Line 4973  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 $request=new HTTP::Request('GET',&tokenwrapper($uri));
       #my $response=$ua->request($request);
       #if ($response->is_success()) {
    # return $response->content;
    #    } else {
    # return -1;
    #    }
     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') {
     return -1;      my $ua=new LWP::UserAgent;
       my $request=new HTTP::Request('GET',&tokenwrapper($uri));
       my $response=$ua->request($request);
       if ($response->is_success()) {
    $info=$response->content;
       } else {
    return -1;
       }
  }   }
  my @parts = ($cdom,$cnum);    my @parts = ($cdom,$cnum); 
  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 4860  sub getfile { Line 5039  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';  }
   
   sub tokenwrapper {
       my $uri=shift;
       $uri=~s/^http\:\/\/([^\/]+)//;
       $uri=~s/^\///;
       $ENV{'user.environment'}=~/\/([^\/]+)\.id/;
       my $token=$1;
       if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) {
           &appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'});
           return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri.
                  (($uri=~/\?/)?'&':'?').'token='.$token.
                                  '&tokenissued='.$perlvar{'lonHostID'};
       } else {
           return '/adm/notfound.html';
     }      }
     return $info;  
 }  }
   
 sub getuploaded {  sub getuploaded {
Line 4906  sub filelocation { Line 5098  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 5102  BEGIN { Line 5306  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 5797  put($namespace,$storehash,$udom,$uname) Line 5997  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.509  
changed lines
  Added in v.1.542

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