[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.301 and 1.396

version 1.301, 2002/11/18 15:16:35 version 1.396, 2003/07/29 05:29:21
Line 47 Line 47
 # 09/01 Guy Albertelli  # 09/01 Guy Albertelli
 # 09/01,10/01,11/01 Gerd Kortemeyer  # 09/01,10/01,11/01 Gerd Kortemeyer
 # YEAR=2001  # YEAR=2001
 # 02/27/01 Scott Harrison  
 # 3/2 Gerd Kortemeyer  # 3/2 Gerd Kortemeyer
 # 3/15,3/19 Scott Harrison  
 # 3/19,3/20 Gerd Kortemeyer  # 3/19,3/20 Gerd Kortemeyer
 # 3/22,3/27,4/2,4/16,4/17 Scott Harrison  
 # 5/26,5/28 Gerd Kortemeyer  # 5/26,5/28 Gerd Kortemeyer
 # 5/30 H. K. Ng  # 5/30 H. K. Ng
 # 6/1 Gerd Kortemeyer  # 6/1 Gerd Kortemeyer
 # July Guy Albertelli  # July Guy Albertelli
 # 8/4,8/7,8/8,8/9,8/11,8/16,8/17,8/18,8/20,8/23,9/20,9/21,9/26,  # 8/4,8/7,8/8,8/9,8/11,8/16,8/17,8/18,8/20,8/23,9/20,9/21,9/26,
 # 10/2 Gerd Kortemeyer  # 10/2 Gerd Kortemeyer
 # 10/5,10/10,11/13,11/15 Scott Harrison  
 # 11/17,11/20,11/22,11/29 Gerd Kortemeyer  # 11/17,11/20,11/22,11/29 Gerd Kortemeyer
 # 12/5 Matthew Hall  # 12/5 Matthew Hall
 # 12/5 Guy Albertelli  # 12/5 Guy Albertelli
 # 12/6,12/7,12/12 Gerd Kortemeyer  # 12/6,12/7,12/12 Gerd Kortemeyer
 # 12/18 Scott Harrison  
 # 12/21,12/22,12/27,12/28 Gerd Kortemeyer  # 12/21,12/22,12/27,12/28 Gerd Kortemeyer
 # YEAR=2002  # YEAR=2002
 # 1/4,2/4,2/7 Gerd Kortemeyer  # 1/4,2/4,2/7 Gerd Kortemeyer
Line 79  use HTTP::Headers; Line 74  use HTTP::Headers;
 use vars   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      %libserv %pr %prp %metacache %packagetab %titlecache 
    %courselogs %accesshash $processmarker $dumpcount      %courselogs %accesshash %userrolehash $processmarker $dumpcount 
    %coursedombuf %coursehombuf %courseresdatacache %domaindescription);     %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache 
      %domaindescription %domain_auth_def %domain_auth_arg_def $tmpdir);
 use IO::Socket;  use IO::Socket;
 use GDBM_File;  use GDBM_File;
 use Apache::Constants qw(:common :http);  use Apache::Constants qw(:common :http);
Line 142  sub reply { Line 138  sub reply {
     unless (defined($hostname{$server})) { return 'no_such_host'; }      unless (defined($hostname{$server})) { return 'no_such_host'; }
     my $answer=subreply($cmd,$server);      my $answer=subreply($cmd,$server);
     if ($answer eq 'con_lost') {      if ($answer eq 'con_lost') {
        #sleep 5;           #sleep 5; 
        #$answer=subreply($cmd,$server);          #$answer=subreply($cmd,$server);
        #if ($answer eq 'con_lost') {          #if ($answer eq 'con_lost') {
  #   &logthis("Second attempt con_lost on $server");   #   &logthis("Second attempt con_lost on $server");
         #   my $peerfile="$perlvar{'lonSockDir'}/$server";          #   my $peerfile="$perlvar{'lonSockDir'}/$server";
         #   my $client=IO::Socket::UNIX->new(Peer    =>"$peerfile",          #   my $client=IO::Socket::UNIX->new(Peer    =>"$peerfile",
Line 215  sub critical { Line 211  sub critical {
             $middlename=substr($middlename,0,16);              $middlename=substr($middlename,0,16);
             $middlename=~s/\W//g;              $middlename=~s/\W//g;
             my $dfilename=              my $dfilename=
              "$perlvar{'lonSockDir'}/delayed/$now.$middlename.$server";        "$perlvar{'lonSockDir'}/delayed/$now.$dumpcount.$$.$middlename.$server";
               $dumpcount++;
             {              {
              my $dfh;               my $dfh;
              if ($dfh=Apache::File->new(">$dfilename")) {               if ($dfh=Apache::File->new(">$dfilename")) {
Line 246  sub critical { Line 243  sub critical {
     }      }
     return $answer;      return $answer;
 }  }
    
   # ------------------------------------------- Transfer profile into environment
   
   sub transfer_profile_to_env {
       my ($lonidsdir,$handle)=@_;
       my @profile;
       {
    my $idf=Apache::File->new("$lonidsdir/$handle.id");
    flock($idf,LOCK_SH);
    @profile=<$idf>;
    $idf->close();
       }
       my $envi;
       for ($envi=0;$envi<=$#profile;$envi++) {
    chomp($profile[$envi]);
    my ($envname,$envvalue)=split(/=/,$profile[$envi]);
    $ENV{$envname} = $envvalue;
       }
       $ENV{'user.environment'} = "$lonidsdir/$handle.id";
   }
   
 # ---------------------------------------------------------- Append Environment  # ---------------------------------------------------------- Append Environment
   
Line 350  sub delenv { Line 367  sub delenv {
     return 'ok';      return 'ok';
 }  }
   
   # ------------------------------------------ Find out current server userload
   # there is a copy in lond
   sub userload {
       my $numusers=0;
       {
    opendir(LONIDS,$perlvar{'lonIDsDir'});
    my $filename;
    my $curtime=time;
    while ($filename=readdir(LONIDS)) {
       if ($filename eq '.' || $filename eq '..') {next;}
       my ($atime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[8];
       if ($curtime-$atime < 3600) { $numusers++; }
    }
    closedir(LONIDS);
       }
       my $userloadpercent=0;
       my $maxuserload=$perlvar{'lonUserLoadLim'};
       if ($maxuserload) {
    $userloadpercent=100*$numusers/$maxuserload;
       }
       $userloadpercent=sprintf("%.2f",$userloadpercent);
       return $userloadpercent;
   }
   
 # ------------------------------------------ Fight off request when overloaded  # ------------------------------------------ Fight off request when overloaded
   
 sub overloaderror {  sub overloaderror {
Line 376  sub overloaderror { Line 417  sub overloaderror {
 # ------------------------------ Find server with least workload from spare.tab  # ------------------------------ Find server with least workload from spare.tab
   
 sub spareserver {  sub spareserver {
     my $loadpercent = shift;      my ($loadpercent,$userloadpercent) = @_;
     my $tryserver;      my $tryserver;
     my $spareserver='';      my $spareserver='';
     my $lowestserver=$loadpercent;       if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
       my $lowestserver=$loadpercent > $userloadpercent?
                $loadpercent :  $userloadpercent;
     foreach $tryserver (keys %spareid) {      foreach $tryserver (keys %spareid) {
        my $answer=reply('load',$tryserver);         my $loadans=reply('load',$tryserver);
          my $userloadans=reply('userload',$tryserver);
          if ($userloadans !~ /\d/) { $userloadans=0; }
          my $answer=$loadans > $userloadans?
                     $loadans :  $userloadans;
        if (($answer =~ /\d/) && ($answer<$lowestserver)) {         if (($answer =~ /\d/) && ($answer<$lowestserver)) {
    $spareserver="http://$hostname{$tryserver}";     $spareserver="http://$hostname{$tryserver}";
            $lowestserver=$answer;             $lowestserver=$answer;
        }         }
     }          }
     return $spareserver;      return $spareserver;
 }  }
   
Line 591  sub idput { Line 638  sub idput {
     }      }
 }  }
   
   # --------------------------------------------------- Assign a key to a student
   
   sub assign_access_key {
   #
   # a valid key looks like uname:udom#comments
   # comments are being appended
   #
       my ($ckey,$cdom,$cnum,$udom,$uname,$logentry)=@_;
       $cdom=
      $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));
       $cnum=
      $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));
       $udom=$ENV{'user.name'} unless (defined($udom));
       $uname=$ENV{'user.domain'} unless (defined($uname));
       my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
       if (($existing{$ckey}=~/^\#(.*)$/) || # - new key
           ($existing{$ckey}=~/^$uname\:$udom\#(.*)$/)) { 
                                                     # assigned to this person
                                                     # - this should not happen,
                                                     # unless something went wrong
                                                     # the first time around
   # ready to assign
           $logentry=$1.'; '.$logentry;
           if (&put('accesskey',{$ckey=>$uname.':'.$udom.'#'.$logentry},
                                                    $cdom,$cnum) eq 'ok') {
   # key now belongs to user
       my $envkey='key.'.$cdom.'_'.$cnum;
               if (&put('environment',{$envkey => $ckey}) eq 'ok') {
                   &appenv('environment.'.$envkey => $ckey);
                   return 'ok';
               } else {
                   return 
     'error: Count not permanently assign key, will need to be re-entered later.';
       }
           } else {
               return 'error: Could not assign key, try again later.';
           }
       } elsif (!$existing{$ckey}) {
   # the key does not exist
    return 'error: The key does not exist';
       } else {
   # the key is somebody else's
    return 'error: The key is already in use';
       }
   }
   
   # ------------------------------------------ put an additional comment on a key
   
   sub comment_access_key {
   #
   # a valid key looks like uname:udom#comments
   # comments are being appended
   #
       my ($ckey,$cdom,$cnum,$logentry)=@_;
       $cdom=
      $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));
       $cnum=
      $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));
       my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
       if ($existing{$ckey}) {
           $existing{$ckey}.='; '.$logentry;
   # ready to assign
           if (&put('accesskeys',{$ckey=>$existing{$ckey}},
                                                    $cdom,$cnum) eq 'ok') {
       return 'ok';
           } else {
       return 'error: Count not store comment.';
           }
       } else {
   # the key does not exist
    return 'error: The key does not exist';
       }
   }
   
   # ------------------------------------------------------ Generate a set of keys
   
   sub generate_access_keys {
       my ($number,$cdom,$cnum,$logentry)=@_;
       $cdom=
      $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));
       $cnum=
      $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));
       unless (&allowed('mky',$cdom)) { return 0; }
       unless (($cdom) && ($cnum)) { return 0; }
       if ($number>10000) { return 0; }
       sleep(2); # make sure don't get same seed twice
       srand(time()^($$+($$<<15))); # from "Programming Perl"
       my $total=0;
       for (my $i=1;$i<=$number;$i++) {
          my $newkey=sprintf("%lx",int(100000*rand)).'-'.
                     sprintf("%lx",int(100000*rand)).'-'.
                     sprintf("%lx",int(100000*rand));
          $newkey=~s/1/g/g; # folks mix up 1 and l
          $newkey=~s/0/h/g; # and also 0 and O
          my %existing=&get('accesskeys',[$newkey],$cdom,$cnum);
          if ($existing{$newkey}) {
              $i--;
          } else {
     if (&put('accesskeys',
                 { $newkey => '# generated '.localtime().
                              ' by '.$ENV{'user.name'}.'@'.$ENV{'user.domain'}.
                              '; '.$logentry },
      $cdom,$cnum) eq 'ok') {
                 $total++;
     }
          }
       }
       &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'},
            'Generated '.$total.' keys for '.$cnum.' at '.$cdom);
       return $total;
   }
   
   # ------------------------------------------------------- Validate an accesskey
   
   sub validate_access_key {
       my ($ckey,$cdom,$cnum,$udom,$uname)=@_;
       $cdom=
      $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));
       $cnum=
      $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));
       $udom=$ENV{'user.name'} unless (defined($udom));
       $uname=$ENV{'user.domain'} unless (defined($uname));
       my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
       return ($existing{$ckey}=~/^$uname\:$udom\#/);
   }
   
 # ------------------------------------- Find the section of student in a course  # ------------------------------------- Find the section of student in a course
   
 sub getsection {  sub getsection {
Line 727  sub currentversion { Line 900  sub currentversion {
   
 sub subscribe {  sub subscribe {
     my $fname=shift;      my $fname=shift;
       if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return ''; }
     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);
     my $home=homeserver($uname,$udom);      my $home=homeserver($uname,$udom);
     if ($home eq 'no_host') {       if ($home eq 'no_host') {
         return 'not_found';           return 'not_found';
     }      }
     my $answer=reply("sub:$fname",$home);      my $answer=reply("sub:$fname",$home);
     if (($answer eq 'con_lost') || ($answer eq 'rejected')) {      if (($answer eq 'con_lost') || ($answer eq 'rejected')) {
Line 806  sub repcopy { Line 980  sub repcopy {
     }      }
 }  }
   
   # ------------------------------------------------ Get server side include body
   sub ssi_body {
       my ($filelink,%form)=@_;
       my $output=($filelink=~/^http\:/?&externalssi($filelink):
                                        &ssi($filelink,%form));
       $output=~s/^.*\<body[^\>]*\>//si;
       $output=~s/\<\/body\s*\>.*$//si;
       $output=~
               s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs;
       return $output;
   }
   
 # --------------------------------------------------------- Server Side Include  # --------------------------------------------------------- Server Side Include
   
 sub ssi {  sub ssi {
Line 829  sub ssi { Line 1015  sub ssi {
     return $response->content;      return $response->content;
 }  }
   
   sub externalssi {
       my ($url)=@_;
       my $ua=new LWP::UserAgent;
       my $request=new HTTP::Request('GET',$url);
       my $response=$ua->request($request);
       return $response->content;
   }
   
 # ------- Add a token to a remote URI's query string to vouch for access rights  # ------- Add a token to a remote URI's query string to vouch for access rights
   
 sub tokenwrapper {  sub tokenwrapper {
Line 840  sub tokenwrapper { Line 1034  sub tokenwrapper {
     if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) {      if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) {
  &appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'});   &appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'});
         return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri.          return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri.
                (($uri=~/\?/)?'&':'?').'token='.$token;                 (($uri=~/\?/)?'&':'?').'token='.$token.
                                  '&tokenissued='.$perlvar{'lonHostID'};
     } else {      } else {
  return '/adm/notfound.html';   return '/adm/notfound.html';
     }      }
Line 853  sub tokenwrapper { Line 1048  sub tokenwrapper {
 sub userfileupload {  sub userfileupload {
     my ($formname,$coursedoc)=@_;      my ($formname,$coursedoc)=@_;
     my $fname=$ENV{'form.'.$formname.'.filename'};      my $fname=$ENV{'form.'.$formname.'.filename'};
   # Replace Windows backslashes by forward slashes
     $fname=~s/\\/\//g;      $fname=~s/\\/\//g;
   # Get rid of everything but the actual filename
     $fname=~s/^.*\/([^\/]+)$/$1/;      $fname=~s/^.*\/([^\/]+)$/$1/;
   # Replace spaces by underscores
       $fname=~s/\s+/\_/g;
   # Replace all other weird characters by nothing
       $fname=~s/[^\w\.\-]//g;
   # 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});
 # Create the directory if not present  # Create the directory if not present
Line 915  sub log { Line 1117  sub log {
 }  }
   
 # ------------------------------------------------------------------ Course Log  # ------------------------------------------------------------------ Course Log
   #
   # This routine flushes several buffers of non-mission-critical nature
   #
   
 sub flushcourselogs {  sub flushcourselogs {
     &logthis('Flushing course log buffers');      &logthis('Flushing log buffers');
   #
   # course logs
   # This is a log of all transactions in a course, which can be used
   # for data mining purposes
   #
   # It also collects the courseid database, which lists last transaction
   # times and course titles for all courseids
   #
       my %courseidbuffer=();
     foreach (keys %courselogs) {      foreach (keys %courselogs) {
         my $crsid=$_;          my $crsid=$_;
         if (&reply('log:'.$coursedombuf{$crsid}.':'.          if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'.
           &escape($courselogs{$crsid}),            &escape($courselogs{$crsid}),
           $coursehombuf{$crsid}) eq 'ok') {            $coursehombuf{$crsid}) eq 'ok') {
     delete $courselogs{$crsid};      delete $courselogs{$crsid};
Line 931  sub flushcourselogs { Line 1145  sub flushcourselogs {
                         " exceeded maximum size, deleting.</font>");                          " exceeded maximum size, deleting.</font>");
                delete $courselogs{$crsid};                 delete $courselogs{$crsid};
             }              }
         }                  }
           if ($courseidbuffer{$coursehombuf{$crsid}}) {
              $courseidbuffer{$coursehombuf{$crsid}}.='&'.
    &escape($crsid).'='.&escape($coursedescrbuf{$crsid});
           } else {
              $courseidbuffer{$coursehombuf{$crsid}}=
    &escape($crsid).'='.&escape($coursedescrbuf{$crsid});
           }    
     }      }
     &logthis('Flushing access logs');  #
   # Write course id database (reverse lookup) to homeserver of courses 
   # Is used in pickcourse
   #
       foreach (keys %courseidbuffer) {
           &courseidput($hostdom{$_},$courseidbuffer{$_},$_);
       }
   #
   # File accesses
   # Writes to the dynamic metadata of resources to get hit counts, etc.
   #
     foreach (keys %accesshash) {      foreach (keys %accesshash) {
         my $entry=$_;          my $entry=$_;
         $entry=~/\_\_\_(\w+)\/(\w+)\/(.*)\_\_\_(\w+)$/;          $entry=~/\_\_\_(\w+)\/(\w+)\/(.*)\_\_\_(\w+)$/;
Line 942  sub flushcourselogs { Line 1173  sub flushcourselogs {
     delete $accesshash{$entry};      delete $accesshash{$entry};
         }          }
     }      }
   #
   # Roles
   # Reverse lookup of user roles for course faculty/staff and co-authorship
   #
       foreach (keys %userrolehash) {
           my $entry=$_;
           my ($role,$uname,$udom,$runame,$rudom,$rsec)=
       split(/\:/,$entry);
           if (&Apache::lonnet::put('nohist_userroles',
                { $role.':'.$uname.':'.$udom.':'.$rsec => $userrolehash{$entry} },
                   $rudom,$runame) eq 'ok') {
       delete $userrolehash{$entry};
           }
       }
     $dumpcount++;      $dumpcount++;
 }  }
   
Line 950  sub courselog { Line 1195  sub courselog {
     $what=time.':'.$what;      $what=time.':'.$what;
     unless ($ENV{'request.course.id'}) { return ''; }      unless ($ENV{'request.course.id'}) { return ''; }
     $coursedombuf{$ENV{'request.course.id'}}=      $coursedombuf{$ENV{'request.course.id'}}=
        $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'.         $ENV{'course.'.$ENV{'request.course.id'}.'.domain'};
       $coursenumbuf{$ENV{'request.course.id'}}=
        $ENV{'course.'.$ENV{'request.course.id'}.'.num'};         $ENV{'course.'.$ENV{'request.course.id'}.'.num'};
     $coursehombuf{$ENV{'request.course.id'}}=      $coursehombuf{$ENV{'request.course.id'}}=
        $ENV{'course.'.$ENV{'request.course.id'}.'.home'};         $ENV{'course.'.$ENV{'request.course.id'}.'.home'};
       $coursedescrbuf{$ENV{'request.course.id'}}=
          $ENV{'course.'.$ENV{'request.course.id'}.'.description'};
     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 990  sub countacc { Line 1238  sub countacc {
         $accesshash{$key}=1;          $accesshash{$key}=1;
     }      }
 }  }
       
   sub linklog {
       my ($from,$to)=@_;
       $from=&declutter($from);
       $to=&declutter($to);
       $accesshash{$from.'___'.$to.'___comefrom'}=1;
       $accesshash{$to.'___'.$from.'___goto'}=1;
   }
     
   sub userrolelog {
       my ($trole,$username,$domain,$area,$tstart,$tend)=@_;
       if (($trole=~/^ca/) || ($trole=~/^in/) || 
           ($trole=~/^cc/) || ($trole=~/^ep/) ||
           ($trole=~/^cr/)) {
          my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
          $userrolehash
            {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
                       =$tend.':'.$tstart;
      }
   }
   
   sub get_course_adv_roles {
       my $cid=shift;
       $cid=$ENV{'request.course.id'} unless (defined($cid));
       my %coursehash=&coursedescription($cid);
       my %returnhash=();
       my %dumphash=
               &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});
       my $now=time;
       foreach (keys %dumphash) {
    my ($tend,$tstart)=split(/\:/,$dumphash{$_});
           if (($tstart) && ($tstart<0)) { next; }
           if (($tend) && ($tend<$now)) { next; }
           if (($tstart) && ($now<$tstart)) { next; }
           my ($role,$username,$domain,$section)=split(/\:/,$_);
           my $key=&plaintext($role);
           if ($section) { $key.=' (Sec/Grp '.$section.')'; }
           if ($returnhash{$key}) {
       $returnhash{$key}.=','.$username.':'.$domain;
           } else {
               $returnhash{$key}=$username.':'.$domain;
           }
        }
       return %returnhash;
   }
   
   # ---------------------------------------------------------- Course ID routines
   # Deal with domain's nohist_courseid.db files
   #
   
   sub courseidput {
       my ($domain,$what,$coursehome)=@_;
       return &reply('courseidput:'.$domain.':'.$what,$coursehome);
   }
   
   sub courseiddump {
       my ($domfilter,$descfilter,$sincefilter)=@_;
       my %returnhash=();
       unless ($domfilter) { $domfilter=''; }
       foreach my $tryserver (keys %libserv) {
    if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) {
       foreach (
                split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.
          $sincefilter.':'.&escape($descfilter),
                                  $tryserver))) {
    my ($key,$value)=split(/\=/,$_);
                   if (($key) && ($value)) {
       $returnhash{&unescape($key)}=&unescape($value);
                   }
               }
   
           }
       }
       return %returnhash;
   }
   
   #
 # ----------------------------------------------------------- Check out an item  # ----------------------------------------------------------- Check out an item
   
 sub checkout {  sub checkout {
Line 1098  sub expirespread { Line 1422  sub expirespread {
 # ----------------------------------------------------- Devalidate Spreadsheets  # ----------------------------------------------------- Devalidate Spreadsheets
   
 sub devalidate {  sub devalidate {
     my $symb=shift;      my ($symb,$uname,$udom)=@_;
     my $cid=$ENV{'request.course.id'};       my $cid=$ENV{'request.course.id'}; 
     if ($cid) {      if ($cid) {
  my $key=$ENV{'user.name'}.':'.$ENV{'user.domain'}.':';          # delete the stored spreadsheets for
           # - the student level sheet of this user in course's homespace
           # - the assessment level sheet for this resource 
           #   for this user in user's homespace
    my $key=$uname.':'.$udom.':';
         my $status=          my $status=
     &del('nohist_calculatedsheets',      &del('nohist_calculatedsheets',
  [$key.'studentcalc'],   [$key.'studentcalc:'],
  $ENV{'course.'.$cid.'.domain'},   $ENV{'course.'.$cid.'.domain'},
  $ENV{'course.'.$cid.'.num'})   $ENV{'course.'.$cid.'.num'})
  .' '.   .' '.
     &del('nohist_calculatedsheets_'.$cid,      &del('nohist_calculatedsheets_'.$cid,
  [$key.'assesscalc:'.$symb]);   [$key.'assesscalc:'.$symb],$udom,$uname);
         unless ($status eq 'ok ok') {          unless ($status eq 'ok ok') {
            &logthis('Could not devalidate spreadsheet '.             &logthis('Could not devalidate spreadsheet '.
                     $ENV{'user.name'}.' at '.$ENV{'user.domain'}.' for '.                      $uname.' at '.$udom.' for '.
     $symb.': '.$status);      $symb.': '.$status);
         }          }
     }      }
Line 1315  sub tmpreset { Line 1643  sub tmpreset {
   my ($symb,$namespace,$domain,$stuname) = @_;    my ($symb,$namespace,$domain,$stuname) = @_;
   if (!$symb) {    if (!$symb) {
     $symb=&symbread();      $symb=&symbread();
     if (!$symb) { $symb= $ENV{'REQUEST_URI'}; }      if (!$symb) { $symb= $ENV{'request.url'}; }
   }    }
   $symb=escape($symb);    $symb=escape($symb);
   
Line 1444  sub store { Line 1772  sub store {
     $symb=&symbclean($symb);      $symb=&symbclean($symb);
     if (!$symb) { unless ($symb=&symbread()) { return ''; } }      if (!$symb) { unless ($symb=&symbread()) { return ''; } }
   
     &devalidate($symb);      if (!$domain) { $domain=$ENV{'user.domain'}; }
       if (!$stuname) { $stuname=$ENV{'user.name'}; }
   
       &devalidate($symb,$stuname,$domain);
   
     $symb=escape($symb);      $symb=escape($symb);
     if (!$namespace) {       if (!$namespace) { 
Line 1452  sub store { Line 1783  sub store {
           return '';             return ''; 
        }          } 
     }      }
     if (!$domain) { $domain=$ENV{'user.domain'}; }  
     if (!$stuname) { $stuname=$ENV{'user.name'}; }  
     if (!$home) { $home=$ENV{'user.home'}; }      if (!$home) { $home=$ENV{'user.home'}; }
     my $namevalue='';      my $namevalue='';
     foreach (keys %$storehash) {      foreach (keys %$storehash) {
Line 1475  sub cstore { Line 1804  sub cstore {
     $symb=&symbclean($symb);      $symb=&symbclean($symb);
     if (!$symb) { unless ($symb=&symbread()) { return ''; } }      if (!$symb) { unless ($symb=&symbread()) { return ''; } }
   
     &devalidate($symb);      if (!$domain) { $domain=$ENV{'user.domain'}; }
       if (!$stuname) { $stuname=$ENV{'user.name'}; }
   
       &devalidate($symb,$stuname,$domain);
   
     $symb=escape($symb);      $symb=escape($symb);
     if (!$namespace) {       if (!$namespace) { 
Line 1483  sub cstore { Line 1815  sub cstore {
           return '';             return ''; 
        }          } 
     }      }
     if (!$domain) { $domain=$ENV{'user.domain'}; }  
     if (!$stuname) { $stuname=$ENV{'user.name'}; }  
     if (!$home) { $home=$ENV{'user.home'}; }      if (!$home) { $home=$ENV{'user.home'}; }
   
     my $namevalue='';      my $namevalue='';
Line 1542  sub coursedescription { Line 1872  sub coursedescription {
     $courseid=~s/\_/\//g;      $courseid=~s/\_/\//g;
     my ($cdomain,$cnum)=split(/\//,$courseid);      my ($cdomain,$cnum)=split(/\//,$courseid);
     my $chome=&homeserver($cnum,$cdomain);      my $chome=&homeserver($cnum,$cdomain);
       my $normalid=$cdomain.'_'.$cnum;
       # need to always cache even if we get errors otherwise we keep 
       # trying and trying and trying to get the course description.
       my %envhash=();
       my %returnhash=();
       $envhash{'course.'.$normalid.'.last_cache'}=time;
     if ($chome ne 'no_host') {      if ($chome ne 'no_host') {
        my %returnhash=&dump('environment',$cdomain,$cnum);         %returnhash=&dump('environment',$cdomain,$cnum);
        if (!exists($returnhash{'con_lost'})) {         if (!exists($returnhash{'con_lost'})) {
            my $normalid=$cdomain.'_'.$cnum;  
            my %envhash=();  
            $returnhash{'home'}= $chome;             $returnhash{'home'}= $chome;
    $returnhash{'domain'} = $cdomain;     $returnhash{'domain'} = $cdomain;
    $returnhash{'num'} = $cnum;     $returnhash{'num'} = $cnum;
Line 1556  sub coursedescription { Line 1890  sub coursedescription {
            $returnhash{'url'}=&clutter($returnhash{'url'});             $returnhash{'url'}=&clutter($returnhash{'url'});
            $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.             $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.
        $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum;         $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum;
            $envhash{'course.'.$normalid.'.last_cache'}=time;  
            $envhash{'course.'.$normalid.'.home'}=$chome;             $envhash{'course.'.$normalid.'.home'}=$chome;
            $envhash{'course.'.$normalid.'.domain'}=$cdomain;             $envhash{'course.'.$normalid.'.domain'}=$cdomain;
            $envhash{'course.'.$normalid.'.num'}=$cnum;             $envhash{'course.'.$normalid.'.num'}=$cnum;
            &appenv(%envhash);  
            return %returnhash;  
        }         }
     }      }
     return ();      &appenv(%envhash);
       return %returnhash;
 }  }
   
 # -------------------------------------------------------- Get user privileges  # -------------------------------------------------------- Get user privileges
Line 1587  sub rolesinit { Line 1919  sub rolesinit {
             my ($trole,$tend,$tstart)=split(/_/,$role);              my ($trole,$tend,$tstart)=split(/_/,$role);
             $userroles.='user.role.'.$trole.'.'.$area.'='.              $userroles.='user.role.'.$trole.'.'.$area.'='.
                         $tstart.'.'.$tend."\n";                          $tstart.'.'.$tend."\n";
   # log the associated role with the area
               &userrolelog($trole,$username,$domain,$area,$tstart,$tend);
             if ($tend!=0) {              if ($tend!=0) {
         if ($tend<$now) {          if ($tend<$now) {
             $trole='';              $trole='';
Line 1598  sub rolesinit { Line 1932  sub rolesinit {
                 }                  }
             }              }
             if (($area ne '') && ($trole ne '')) {              if (($area ne '') && ($trole ne '')) {
        my $spec=$trole.'.'.$area;   my $spec=$trole.'.'.$area;
                my ($tdummy,$tdomain,$trest)=split(/\//,$area);   my ($tdummy,$tdomain,$trest)=split(/\//,$area);
                if ($trole =~ /^cr\//) {   if ($trole =~ /^cr\//) {
    my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);      my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
                    my $homsvr=homeserver($rauthor,$rdomain);       my $homsvr=homeserver($rauthor,$rdomain);
                    if ($hostname{$homsvr} ne '') {      if ($hostname{$homsvr} ne '') {
                       my $roledef=   my ($rdummy,$roledef)=
   reply("get:$rdomain:$rauthor:roles:rolesdef_$rrole",     &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);
                                 $homsvr);  
                       if (($roledef ne 'con_lost') && ($roledef ne '')) {   if (($rdummy ne 'con_lost') && ($roledef ne '')) {
                          my ($syspriv,$dompriv,$coursepriv)=      my ($syspriv,$dompriv,$coursepriv)=
      split(/\_/,unescape($roledef));   split(/\_/,$roledef);
                   $allroles{'cm./'}.=':'.$syspriv;      if (defined($syspriv)) {
                          $allroles{$spec.'./'}.=':'.$syspriv;   $allroles{'cm./'}.=':'.$syspriv;
                          if ($tdomain ne '') {   $allroles{$spec.'./'}.=':'.$syspriv;
                              $allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv;      }
                              $allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;      if ($tdomain ne '') {
                              if ($trest ne '') {   if (defined($dompriv)) {
                 $allroles{'cm.'.$area}.=':'.$coursepriv;      $allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv;
                 $allroles{$spec.'.'.$area}.=':'.$coursepriv;      $allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;
                              }   }
                  }   if ($trest ne '') {
                       }      if (defined($coursepriv)) {
                    }   $allroles{'cm.'.$area}.=':'.$coursepriv;
                } else {   $allroles{$spec.'.'.$area}.=':'.$coursepriv;
            $allroles{'cm./'}.=':'.$pr{$trole.':s'};      }
            $allroles{$spec.'./'}.=':'.$pr{$trole.':s'};   }
                    if ($tdomain ne '') {      }
                      $allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};   }
                      $allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};      }
                       if ($trest ne '') {   } else {
           $allroles{'cm.'.$area}.=':'.$pr{$trole.':c'};      if (defined($pr{$trole.':s'})) {
           $allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'};   $allroles{'cm./'}.=':'.$pr{$trole.':s'};
                       }   $allroles{$spec.'./'}.=':'.$pr{$trole.':s'};
            }      }
        }      if ($tdomain ne '') {
    if (defined($pr{$trole.':d'})) {
       $allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
       $allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
    }
    if ($trest ne '') {
       if (defined($pr{$trole.':c'})) {
    $allroles{'cm.'.$area}.=':'.$pr{$trole.':c'};
    $allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'};
       }
    }
       }
    }
             }              }
           }             } 
         }          }
Line 1731  sub dump { Line 2077  sub dump {
    return %returnhash;     return %returnhash;
 }  }
   
   # --------------------------------------------------------------- currentdump
   sub currentdump {
      my ($courseid,$sdom,$sname)=@_;
      $courseid = $ENV{'request.course.id'} if (! defined($courseid));
      $sdom     = $ENV{'user.domain'}       if (! defined($sdom));
      $sname    = $ENV{'user.name'}         if (! defined($sname));
      my $uhome = &homeserver($sname,$sdom);
      my $rep=reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome);
      return if ($rep =~ /^(error:|no_such_host)/);
      #
      my %returnhash=();
      #
      if ($rep eq "unknown_cmd") { 
          # an old lond will not know currentdump
          # Do a dump and make it look like a currentdump
          my @tmp = &dump($courseid,$sdom,$sname,'.');
          return if ($tmp[0] =~ /^(error:|no_such_host)/);
          my %hash = @tmp;
          @tmp=();
          # Code ripped from lond, essentially.  The only difference
          # here is the unescaping done by lonnet::dump().  Conceivably
          # we might run in to problems with parameter names =~ /^v\./
          while (my ($key,$value) = each(%hash)) {
              my ($v,$symb,$param) = split(/:/,$key);
              next if ($v eq 'version' || $symb eq 'keys');
              next if (exists($returnhash{$symb}) &&
                       exists($returnhash{$symb}->{$param}) &&
                       $returnhash{$symb}->{'v.'.$param} > $v);
              $returnhash{$symb}->{$param}=$value;
              $returnhash{$symb}->{'v.'.$param}=$v;
          }
          #
          # Remove all of the keys in the hashes which keep track of
          # the version of the parameter.
          while (my ($symb,$param_hash) = each(%returnhash)) {
              # use a foreach because we are going to delete from the hash.
              foreach my $key (keys(%$param_hash)) {
                  delete($param_hash->{$key}) if ($key =~ /^v\./);
              }
          }
      } else {
          my @pairs=split(/\&/,$rep);
          foreach (@pairs) {
              my ($key,$value)=split(/=/,$_);
              my ($symb,$param) = split(/:/,$key);
              $returnhash{&unescape($symb)}->{&unescape($param)} = 
                                                             &unescape($value);
          }
      }
      return %returnhash;
   }
   
 # --------------------------------------------------------------- put interface  # --------------------------------------------------------------- put interface
   
 sub put {  sub put {
Line 1784  sub eget { Line 2182  sub eget {
    return %returnhash;     return %returnhash;
 }  }
   
   # ---------------------------------------------- Custom access rule evaluation
   
   sub customaccess {
       my ($priv,$uri)=@_;
       my ($urole,$urealm)=split(/\./,$ENV{'request.role'});
       $urealm=~s/^\W//;
       my ($udom,$ucrs,$usec)=split(/\//,$urealm);
       my $access=0;
       foreach (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) {
    my ($effect,$realm,$role)=split(/\:/,$_);
           if ($role) {
      if ($role ne $urole) { next; }
           }
           foreach (split(/\s*\,\s*/,$realm)) {
               my ($tdom,$tcrs,$tsec)=split(/\_/,$_);
               if ($tdom) {
    if ($tdom ne $udom) { next; }
               }
               if ($tcrs) {
    if ($tcrs ne $ucrs) { next; }
               }
               if ($tsec) {
    if ($tsec ne $usec) { next; }
               }
               $access=($effect eq 'allow');
               last;
           }
       }
       return $access;
   }
   
 # ------------------------------------------------- Check for a user privilege  # ------------------------------------------------- Check for a user privilege
   
 sub allowed {  sub allowed {
Line 1822  sub allowed { Line 2251  sub allowed {
             # Library role, so allow browsing of resources in this domain.              # Library role, so allow browsing of resources in this domain.
             return 'F';              return 'F';
         }          }
           if ($copyright eq 'custom') {
       unless (&customaccess($priv,$uri)) { return ''; }
           }
     }      }
     # Domain coordinator is trying to create a course      # Domain coordinator is trying to create a course
     if (($priv eq 'ccc') && ($ENV{'request.role'} =~ /^dc\./)) {      if (($priv eq 'ccc') && ($ENV{'request.role'} =~ /^dc\./)) {
Line 1858  sub allowed { Line 2290  sub allowed {
        $thisallowed.=$1;         $thisallowed.=$1;
     }      }
   
   # URI is an uploaded document for this course
   
       if (($priv eq 'bre') && 
           ($uri=~/^uploaded\/$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}\/$ENV{'course.'.$ENV{'request.course.id'}.'.num'}/)) {
           return 'F';
       }
 # Full access at system, domain or course-wide level? Exit.  # Full access at system, domain or course-wide level? Exit.
   
     if ($thisallowed=~/F/) {      if ($thisallowed=~/F/) {
Line 2033  sub allowed { Line 2471  sub allowed {
   
    if ($thisallowed=~/R/) {     if ($thisallowed=~/R/) {
        my $rolecode=(split(/\./,$ENV{'request.role'}))[0];         my $rolecode=(split(/\./,$ENV{'request.role'}))[0];
        my $filename=$perlvar{'lonDocRoot'}.'/res/'.$uri.'.meta';         if (&metadata($uri,'roledeny')=~/$rolecode/) {
        if (-e $filename) {    &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
            my @content;  
            {  
      my $fh=Apache::File->new($filename);  
              @content=<$fh>;  
    }  
            if (join('',@content)=~  
                     /\<roledeny[^\>]*\>[^\<]*$rolecode[^\<]*\<\/roledeny\>/) {  
        &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},  
                     'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);                      'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
            return '';            return '';
   
            }  
        }         }
    }     }
   
Line 2077  sub is_on_map { Line 2505  sub is_on_map {
     my $filename=$uriparts[$#uriparts];      my $filename=$uriparts[$#uriparts];
     my $pathname=$uri;      my $pathname=$uri;
     $pathname=~s|/\Q$filename\E$||;      $pathname=~s|/\Q$filename\E$||;
       $pathname=~s/^adm\/wrapper\///;    
     #Trying to find the conditional for the file      #Trying to find the conditional for the file
     my $match=($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~      my $match=($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
        /\&\Q$filename\E\:([\d\|]+)\&/);         /\&\Q$filename\E\:([\d\|]+)\&/);
Line 2092  sub is_on_map { Line 2521  sub is_on_map {
 sub definerole {  sub definerole {
   if (allowed('mcr','/')) {    if (allowed('mcr','/')) {
     my ($rolename,$sysrole,$domrole,$courole)=@_;      my ($rolename,$sysrole,$domrole,$courole)=@_;
     foreach (split('/',$sysrole)) {      foreach (split(':',$sysrole)) {
  my ($crole,$cqual)=split(/\&/,$_);   my ($crole,$cqual)=split(/\&/,$_);
         if ($pr{'cr:s'}!~/$crole/) { return "refused:s:$crole"; }          if ($pr{'cr:s'}!~/$crole/) { return "refused:s:$crole"; }
         if ($pr{'cr:s'}=~/$crole\&/) {          if ($pr{'cr:s'}=~/$crole\&/) {
Line 2101  sub definerole { Line 2530  sub definerole {
             }              }
         }          }
     }      }
     foreach (split('/',$domrole)) {      foreach (split(':',$domrole)) {
  my ($crole,$cqual)=split(/\&/,$_);   my ($crole,$cqual)=split(/\&/,$_);
         if ($pr{'cr:d'}!~/$crole/) { return "refused:d:$crole"; }          if ($pr{'cr:d'}!~/$crole/) { return "refused:d:$crole"; }
         if ($pr{'cr:d'}=~/$crole\&/) {          if ($pr{'cr:d'}=~/$crole\&/) {
Line 2110  sub definerole { Line 2539  sub definerole {
             }              }
         }          }
     }      }
     foreach (split('/',$courole)) {      foreach (split(':',$courole)) {
  my ($crole,$cqual)=split(/\&/,$_);   my ($crole,$cqual)=split(/\&/,$_);
         if ($pr{'cr:c'}!~/$crole/) { return "refused:c:$crole"; }          if ($pr{'cr:c'}!~/$crole/) { return "refused:c:$crole"; }
         if ($pr{'cr:c'}=~/$crole\&/) {          if ($pr{'cr:c'}=~/$crole\&/) {
Line 2219  sub plaintext { Line 2648  sub plaintext {
 # ----------------------------------------------------------------- Assign Role  # ----------------------------------------------------------------- Assign Role
   
 sub assignrole {  sub assignrole {
     my ($udom,$uname,$url,$role,$end,$start)=@_;      my ($udom,$uname,$url,$role,$end,$start,$deleteflag)=@_;
     my $mrole;      my $mrole;
     if ($role =~ /^cr\//) {      if ($role =~ /^cr\//) {
  unless (&allowed('ccr',$url)) {          my $cwosec=$url;
           $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
    unless (&allowed('ccr',$cwosec)) {
            &logthis('Refused custom assignrole: '.             &logthis('Refused custom assignrole: '.
              $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.               $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
     $ENV{'user.name'}.' at '.$ENV{'user.domain'});      $ENV{'user.name'}.' at '.$ENV{'user.domain'});
Line 2232  sub assignrole { Line 2663  sub assignrole {
     } else {      } else {
         my $cwosec=$url;          my $cwosec=$url;
         $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;          $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
         unless (&allowed('c'.$role,$cwosec)) {           unless ((&allowed('c'.$role,$cwosec)) || &allowed('c'.$role,$udom)) { 
            &logthis('Refused assignrole: '.             &logthis('Refused assignrole: '.
              $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.               $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
     $ENV{'user.name'}.' at '.$ENV{'user.domain'});      $ENV{'user.name'}.' at '.$ENV{'user.domain'});
Line 2250  sub assignrole { Line 2681  sub assignrole {
            $command.='_0_'.$start;             $command.='_0_'.$start;
         }          }
     }      }
     return &reply($command,&homeserver($uname,$udom));  # actually delete
       if ($deleteflag) {
    if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) {
   # modify command to delete the role
              $command="encrypt:rolesdel:$ENV{'user.domain'}:$ENV{'user.name'}:".
                   "$udom:$uname:$url".'_'."$mrole";
      &logthis("$ENV{'user.name'} at $ENV{'user.domain'} deletes $mrole in $url for $uname at $udom"); 
   # set start and finish to negative values for userrolelog
              $start=-1;
              $end=-1;
           }
       }
   # send command
       my $answer=&reply($command,&homeserver($uname,$udom));
   # log new user role if status is ok
       if ($answer eq 'ok') {
    &userrolelog($mrole,$uname,$udom,$url,$start,$end);
       }
       return $answer;
 }  }
   
 # -------------------------------------------------- Modify user authentication  # -------------------------------------------------- Modify user authentication
Line 2285  sub modifyuser { Line 2734  sub modifyuser {
     my ($udom,    $uname, $uid,      my ($udom,    $uname, $uid,
         $umode,   $upass, $first,          $umode,   $upass, $first,
         $middle,  $last,  $gene,          $middle,  $last,  $gene,
         $forceid, $desiredhome)=@_;          $forceid, $desiredhome, $email)=@_;
     $udom=~s/\W//g;      $udom=~s/\W//g;
     $uname=~s/\W//g;      $uname=~s/\W//g;
     &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.      &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
Line 2327  sub modifyuser { Line 2776  sub modifyuser {
         }             }   
         $uhome=&homeserver($uname,$udom,'true');          $uhome=&homeserver($uname,$udom,'true');
         if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) {          if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) {
     return 'error: verify home';      return 'error: unable verify users home machine.';
         }          }
     }   # End of creation of new user      }   # End of creation of new user
 # ---------------------------------------------------------------------- Add ID  # ---------------------------------------------------------------------- Add ID
Line 2337  sub modifyuser { Line 2786  sub modifyuser {
        if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/)          if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/) 
          && (!$forceid)) {           && (!$forceid)) {
   unless ($uid eq $uidhash{$uname}) {    unless ($uid eq $uidhash{$uname}) {
       return 'error: mismatch '.$uidhash{$uname}.' versus '.$uid;        return 'error: user id "'.$uid.'" does not match '.
                     'current user id "'.$uidhash{$uname}.'".';
           }            }
        } else {         } else {
   &idput($udom,($uname => $uid));    &idput($udom,($uname => $uid));
        }         }
     }      }
 # -------------------------------------------------------------- Add names, etc  # -------------------------------------------------------------- Add names, etc
     my %names=&get('environment',      my @tmp=&get('environment',
    ['firstname','middlename','lastname','generation'],     ['firstname','middlename','lastname','generation'],
    $udom,$uname);     $udom,$uname);
     if ($names{'firstname'} =~ m/^error:.*/) { %names=(); }      my %names;
       if ($tmp[0] =~ m/^error:.*/) { 
           %names=(); 
       } else {
           %names = @tmp;
       }
   #
   # Make sure to not trash student environment if instructor does not bother
   # to supply name and email information
   #
     if ($first)  { $names{'firstname'}  = $first; }      if ($first)  { $names{'firstname'}  = $first; }
     if ($middle) { $names{'middlename'} = $middle; }      if (defined($middle)) { $names{'middlename'} = $middle; }
     if ($last)   { $names{'lastname'}   = $last; }      if ($last)   { $names{'lastname'}   = $last; }
     if ($gene)   { $names{'generation'} = $gene; }      if (defined($gene))   { $names{'generation'} = $gene; }
       if ($email)  { $names{'notification'} = $email;
                      $names{'critnotification'} = $email; }
   
     my $reply = &put('environment', \%names, $udom,$uname);      my $reply = &put('environment', \%names, $udom,$uname);
     if ($reply ne 'ok') { return 'error: '.$reply; }      if ($reply ne 'ok') { return 'error: '.$reply; }
     &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.      &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
Line 2365  sub modifyuser { Line 2827  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)=@_;          $end,$start,$forceid,$desiredhome,$email)=@_;
     my $cid='';      my $cid='';
     unless ($cid=$ENV{'request.course.id'}) {      unless ($cid=$ENV{'request.course.id'}) {
  return 'not_in_class';   return 'not_in_class';
Line 2373  sub modifystudent { Line 2835  sub modifystudent {
 # --------------------------------------------------------------- Make the user  # --------------------------------------------------------------- Make the user
     my $reply=&modifyuser      my $reply=&modifyuser
  ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid,   ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid,
          $desiredhome);           $desiredhome,$email);
     unless ($reply eq 'ok') { return $reply; }      unless ($reply eq 'ok') { return $reply; }
     # This will cause &modify_student_enrollment to get the uid from the      # This will cause &modify_student_enrollment to get the uid from the
     # students environment      # students environment
Line 2491  sub createcourse { Line 2953  sub createcourse {
  return 'error: no such course';   return 'error: no such course';
     }      }
 # ----------------------------------------------------------------- Course made  # ----------------------------------------------------------------- Course made
   # log existance
       &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description),
                    $uhome);
       &flushcourselogs();
   # set toplevel url
     my $topurl=$url;      my $topurl=$url;
     unless ($nonstandard) {      unless ($nonstandard) {
 # ------------------------------------------ For standard courses, make top url  # ------------------------------------------ For standard courses, make top url
Line 2519  ENDINITMAP Line 2986  ENDINITMAP
 # ---------------------------------------------------------- Assign Custom Role  # ---------------------------------------------------------- Assign Custom Role
   
 sub assigncustomrole {  sub assigncustomrole {
     my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start)=@_;      my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag)=@_;
     return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,      return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,
                        $end,$start);                         $end,$start,$deleteflag);
 }  }
   
 # ----------------------------------------------------------------- Revoke Role  # ----------------------------------------------------------------- Revoke Role
   
 sub revokerole {  sub revokerole {
     my ($udom,$uname,$url,$role)=@_;      my ($udom,$uname,$url,$role,$deleteflag)=@_;
     my $now=time;      my $now=time;
     return &assignrole($udom,$uname,$url,$role,$now);      return &assignrole($udom,$uname,$url,$role,$now,$deleteflag);
 }  }
   
 # ---------------------------------------------------------- Revoke Custom Role  # ---------------------------------------------------------- Revoke Custom Role
   
 sub revokecustomrole {  sub revokecustomrole {
     my ($udom,$uname,$url,$rdom,$rnam,$rolename)=@_;      my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag)=@_;
     my $now=time;      my $now=time;
     return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now);      return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now,
              $deleteflag);
 }  }
   
 # ------------------------------------------------------------ Directory lister  # ------------------------------------------------------------ Directory lister
Line 2626  sub GetFileTimestamp { Line 3094  sub GetFileTimestamp {
     $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;      $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
     my $proname="$studentDomain/$subdir/$studentName";      my $proname="$studentDomain/$subdir/$studentName";
     $proname .= '/'.$filename;      $proname .= '/'.$filename;
     my @dir = &Apache::lonnet::dirlist($proname, $studentDomain, $studentName,      my ($fileStat) = &Apache::lonnet::dirlist($proname, $studentDomain, 
                                        $root);                                                $studentName, $root);
     my $fileStat = $dir[0];  
     my @stats = split('&', $fileStat);      my @stats = split('&', $fileStat);
     if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {      if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
         return $stats[9];          # @stats contains first the filename, then the stat output
           return $stats[10]; # so this is 10 instead of 9.
     } else {      } else {
         return -1;          return -1;
     }      }
Line 2715  sub courseresdata { Line 3183  sub courseresdata {
  if ($tmp !~ /^(con_lost|error|no_such_host)/i) {   if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
     $courseresdatacache{$hashid.'.time'}=time;      $courseresdatacache{$hashid.'.time'}=time;
     $courseresdatacache{$hashid}=\%dumpreply;      $courseresdatacache{$hashid}=\%dumpreply;
    } elsif ($tmp =~ /^(con_lost|no_such_host)/) {
       return $tmp;
  }   }
     }      }
     foreach my $item (@which) {      foreach my $item (@which) {
Line 2725  sub courseresdata { Line 3195  sub courseresdata {
     return undef;      return undef;
 }  }
   
 # --------------------------------------------------------- Value of a Variable  #
   # EXT resource caching routines
   #
   
   sub clear_EXT_cache_status {
       &delenv('cache.EXT.');
   }
   
   sub EXT_cache_status {
       my ($target_domain,$target_user) = @_;
       my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;
       if (exists($ENV{$cachename}) && ($ENV{$cachename}+600) > time) {
           # We know already the user has no data
           return 1;
       } else {
           return 0;
       }
   }
   
   sub EXT_cache_set {
       my ($target_domain,$target_user) = @_;
       my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;
       &appenv($cachename => time);
   }
   
   # --------------------------------------------------------- Value of a Variable
 sub EXT {  sub EXT {
     my ($varname,$symbparm,$udom,$uname,)=@_;      my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_;
   
     unless ($varname) { return ''; }      unless ($varname) { return ''; }
   
     #get real user name/domain, courseid and symb      #get real user name/domain, courseid and symb
     my $courseid;      my $courseid;
       my $publicuser;
     if (!($uname && $udom)) {      if (!($uname && $udom)) {
       (my $cursymb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();        (my $cursymb,$courseid,$udom,$uname,$publicuser)=
     &Apache::lonxml::whichuser($symbparm);
       if (!$symbparm) { $symbparm=$cursymb; }        if (!$symbparm) { $symbparm=$cursymb; }
     } else {      } else {
  $courseid=$ENV{'request.course.id'};   $courseid=$ENV{'request.course.id'};
     }      }
   
     my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);      my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);
     my $rest;      my $rest;
     if ($therest[0]) {      if (defined($therest[0])) {
        $rest=join('.',@therest);         $rest=join('.',@therest);
     } else {      } else {
        $rest='';         $rest='';
     }      }
   
     my $qualifierrest=$qualifier;      my $qualifierrest=$qualifier;
     if ($rest) { $qualifierrest.='.'.$rest; }      if ($rest) { $qualifierrest.='.'.$rest; }
     my $spacequalifierrest=$space;      my $spacequalifierrest=$space;
Line 2755  sub EXT { Line 3250  sub EXT {
     if ($realm eq 'user') {      if ($realm eq 'user') {
 # --------------------------------------------------------------- user.resource  # --------------------------------------------------------------- user.resource
  if ($space eq 'resource') {   if ($space eq 'resource') {
     my %restored=&restore(undef,undef,$udom,$uname);      if (defined($Apache::lonhomework::parsing_a_problem)) {
             return $restored{$qualifierrest};   return $Apache::lonhomework::history{$qualifierrest};
       } else {
    my %restored;
    if ($publicuser || $ENV{'request.state'} eq 'construct') {
       %restored=&tmprestore($symbparm,$courseid,$udom,$uname);
    } else {
       %restored=&restore($symbparm,$courseid,$udom,$uname);
    }
    return $restored{$qualifierrest};
       }
 # ----------------------------------------------------------------- user.access  # ----------------------------------------------------------------- user.access
         } elsif ($space eq 'access') {          } elsif ($space eq 'access') {
     # FIXME - not supporting calls for a specific user      # FIXME - not supporting calls for a specific user
Line 2767  sub EXT { Line 3271  sub EXT {
  ($udom eq $ENV{'user.domain'})) {   ($udom eq $ENV{'user.domain'})) {
  return $ENV{join('.',('environment',$qualifierrest))};   return $ENV{join('.',('environment',$qualifierrest))};
     } else {      } else {
  my %returnhash=&userenvironment($udom,$uname,$qualifierrest);   my %returnhash;
    if (!$publicuser) {
       %returnhash=&userenvironment($udom,$uname,
    $qualifierrest);
    }
  return $returnhash{$qualifierrest};   return $returnhash{$qualifierrest};
     }      }
 # ----------------------------------------------------------------- user.course  # ----------------------------------------------------------------- user.course
Line 2791  sub EXT { Line 3299  sub EXT {
             return $uname;              return $uname;
 # ---------------------------------------------------- Any other user namespace  # ---------------------------------------------------- Any other user namespace
         } else {          } else {
             my $item=($rest)?$qualifier.'.'.$rest:$qualifier;      my %reply;
             my %reply=&get($space,[$item]);      if (!$publicuser) {
             return $reply{$item};   %reply=&get($space,[$qualifierrest],$udom,$uname);
       }
       return $reply{$qualifierrest};
         }          }
     } elsif ($realm eq 'query') {      } elsif ($realm eq 'query') {
 # ---------------------------------------------- pull stuff out of query string  # ---------------------------------------------- pull stuff out of query string
         &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'},[$space]);          &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'},
  return $ENV{'form.'.$space};    [$spacequalifierrest]);
    return $ENV{'form.'.$spacequalifierrest}; 
    } elsif ($realm eq 'request') {     } elsif ($realm eq 'request') {
 # ------------------------------------------------------------- request.browser  # ------------------------------------------------------------- request.browser
         if ($space eq 'browser') {          if ($space eq 'browser') {
Line 2812  sub EXT { Line 3323  sub EXT {
         return $ENV{'course.'.$courseid.'.'.$spacequalifierrest};          return $ENV{'course.'.$courseid.'.'.$spacequalifierrest};
     } elsif ($realm eq 'resource') {      } elsif ($realm eq 'resource') {
   
  if ($courseid eq $ENV{'request.course.id'}) {   my $section;
    if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) {
   
     #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;      #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
   
Line 2824  sub EXT { Line 3336  sub EXT {
     my $symbparm=$symbp.'.'.$spacequalifierrest;      my $symbparm=$symbp.'.'.$spacequalifierrest;
     my $mapparm=$mapp.'___(all).'.$spacequalifierrest;      my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
   
     my $section;  
     if (($ENV{'user.name'} eq $uname) &&      if (($ENV{'user.name'} eq $uname) &&
  ($ENV{'user.domain'} eq $udom)) {   ($ENV{'user.domain'} eq $udom)) {
  $section=$ENV{'request.course.sec'};   $section=$ENV{'request.course.sec'};
     } else {      } else {
  $section=&usection($udom,$uname,$courseid);                  if (! defined($usection)) {
                       $section=&usection($udom,$uname,$courseid);
                   } else {
                       $section = $usection;
                   }
     }      }
   
     my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;      my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
Line 2841  sub EXT { Line 3356  sub EXT {
     my $courselevelm=$courseid.'.'.$mapparm;      my $courselevelm=$courseid.'.'.$mapparm;
   
 # ----------------------------------------------------------- first, check user  # ----------------------------------------------------------- first, check user
     my %resourcedata=&get('resourcedata',      #most student don\'t have any data set, check if there is some data
   [$courselevelr,$courselevelm,$courselevel],              #every thirty minutes
  $udom,$uname);      if (! &EXT_cache_status($udom,$uname)) {
     if (($resourcedata{$courselevelr}!~/^error\:/) &&   my %resourcedata=&get('resourcedata',
  ($resourcedata{$courselevelr}!~/^con_lost/)) {        [$courselevelr,$courselevelm,$courselevel],
         $udom,$uname);
  if ($resourcedata{$courselevelr}) {   my ($tmp)=keys(%resourcedata);
     return $resourcedata{$courselevelr}; }   if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) {
  if ($resourcedata{$courselevelm}) {      if ($resourcedata{$courselevelr}) {
     return $resourcedata{$courselevelm}; }   return $resourcedata{$courselevelr}; }
  if ($resourcedata{$courselevel}) {      if ($resourcedata{$courselevelm}) {
     return $resourcedata{$courselevel}; }   return $resourcedata{$courselevelm}; }
     } else {      if ($resourcedata{$courselevel}) {
  if ($resourcedata{$courselevelr}!~/No such file/) {   return $resourcedata{$courselevel}; }
     &logthis("<font color=blue>WARNING:".   } else {
      " Trying to get resource data for ".      if ($tmp!~/No such file/) {
      $uname." at ".$udom.": ".   &logthis("<font color=blue>WARNING:".
      $resourcedata{$courselevelr}."</font>");   " Trying to get resource data for ".
    $uname." at ".$udom.": ".
    $tmp."</font>");
       } elsif ($tmp=~/error:No such file/) {
                           &EXT_cache_set($udom,$uname);
       } elsif ($tmp =~ /^(con_lost|no_such_host)/) {
    return $tmp;
       }
  }   }
     }      }
   
Line 2899  sub EXT { Line 3421  sub EXT {
   
 # ------------------------------------------------------------------ Cascade up  # ------------------------------------------------------------------ Cascade up
  unless ($space eq '0') {   unless ($space eq '0') {
     my ($part,$id)=split(/\_/,$space);      my @parts=split(/_/,$space);
     if ($id) {      my $id=pop(@parts);
  my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,      my $part=join('_',@parts);
      $symbparm,$udom,$uname);      if ($part eq '') { $part='0'; }
  if (defined($partgeneral)) { return $partgeneral; }      my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
     } else {   $symbparm,$udom,$uname,$section,1);
  my $resourcegeneral=&EXT('resource.0.'.$qualifierrest,      if (defined($partgeneral)) { return $partgeneral; }
  $symbparm,$udom,$uname);  
  if (defined($resourcegeneral)) { return $resourcegeneral; }  
     }  
  }   }
    if ($recurse) { return undef; }
    my $pack_def=&packages_tab_default($filename,$varname);
    if (defined($pack_def)) { return $pack_def; }
   
 # ---------------------------------------------------- Any other user namespace  # ---------------------------------------------------- Any other user namespace
     } elsif ($realm eq 'environment') {      } elsif ($realm eq 'environment') {
Line 2930  sub EXT { Line 3452  sub EXT {
     return '';      return '';
 }  }
   
   sub packages_tab_default {
       my ($uri,$varname)=@_;
       my (undef,$part,$name)=split(/\./,$varname);
       my $packages=&metadata($uri,'packages');
       foreach my $package (split(/,/,$packages)) {
    my ($pack_type,$pack_part)=split(/_/,$package,2);
    if ($pack_part eq $part) {
       return $packagetab{"$pack_type&$name&default"};
    }
       }
       return undef;
   }
   
   sub add_prefix_and_part {
       my ($prefix,$part)=@_;
       my $keyroot;
       if (defined($prefix) && $prefix !~ /^__/) {
    # prefix that has a part already
    $keyroot=$prefix;
       } elsif (defined($prefix)) {
    # prefix that is missing a part
    if (defined($part)) { $keyroot='_'.$part.substr($prefix,1); }
       } else {
    # no prefix at all
    if (defined($part)) { $keyroot='_'.$part; }
       }
       return $keyroot;
   }
   
 # ---------------------------------------------------------------- Get metadata  # ---------------------------------------------------------------- Get metadata
   
 sub metadata {  sub metadata {
Line 2958  sub metadata { Line 3509  sub metadata {
         }          }
         my %metathesekeys=();          my %metathesekeys=();
         unless ($filename=~/\.meta$/) { $filename.='.meta'; }          unless ($filename=~/\.meta$/) { $filename.='.meta'; }
  my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename);   my $metastring=&getfile(&filelocation('',&clutter($filename)));
         my $parser=HTML::LCParser->new(\$metastring);          my $parser=HTML::LCParser->new(\$metastring);
         my $token;          my $token;
         undef %metathesekeys;          undef %metathesekeys;
    delete($metacache{$uri.':packages'});
         while ($token=$parser->get_token) {          while ($token=$parser->get_token) {
            if ($token->[0] eq 'S') {      if ($token->[0] eq 'S') {
      if (defined($token->[2]->{'package'})) {   if (defined($token->[2]->{'package'})) {
 #  #
 # This is a package - get package info  # This is a package - get package info
 #  #
       my $package=$token->[2]->{'package'};      my $package=$token->[2]->{'package'};
       my $keyroot='';      my $keyroot=&add_prefix_and_part($prefix,$token->[2]->{'part'});
               if ($prefix) {      if (defined($token->[2]->{'id'})) { 
   $keyroot.=$prefix;   $keyroot.='_'.$token->[2]->{'id'}; 
               } else {      }
                 if (defined($token->[2]->{'part'})) {       if ($metacache{$uri.':packages'}) {
                    $keyroot.='_'.$token->[2]->{'part'};    $metacache{$uri.':packages'}.=','.$package.$keyroot;
         }      } else {
       }   $metacache{$uri.':packages'}=$package.$keyroot;
               if (defined($token->[2]->{'id'})) {       }
                  $keyroot.='_'.$token->[2]->{'id'};       foreach (keys %packagetab) {
       }   if ($_=~/^$package\&/) {
               if ($metacache{$uri.':packages'}) {      my ($pack,$name,$subp)=split(/\&/,$_);
                  $metacache{$uri.':packages'}.=','.$package.$keyroot;      # ignore package.tab specified default values
               } else {                              # here &package_tab_default() will fetch those
                  $metacache{$uri.':packages'}=$package.$keyroot;      if ($subp eq 'default') { next; }
       }      my $value=$packagetab{$_};
               foreach (keys %packagetab) {      my $part=$keyroot;
   if ($_=~/^$package\&/) {      $part=~s/^\_//;
       my ($pack,$name,$subp)=split(/\&/,$_);      if ($subp eq 'display') {
                       my $value=$packagetab{$_};   $value.=' [Part: '.$part.']';
       my $part=$keyroot;      }
                       $part=~s/^\_//;      my $unikey='parameter'.$keyroot.'_'.$name;
                       if ($subp eq 'display') {      $metacache{$uri.':'.$unikey.'.part'}=$part;
   $value.=' [Part: '.$part.']';      $metathesekeys{$unikey}=1;
                       }      unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) {
                       my $unikey='parameter'.$keyroot.'_'.$name;   $metacache{$uri.':'.$unikey.'.'.$subp}=$value;
                       $metathesekeys{$unikey}=1;      }
                       $metacache{$uri.':'.$unikey.'.part'}=$part;      if (defined($metacache{$uri.':'.$unikey.'.default'})) {
                       unless    $metacache{$uri.':'.$unikey}=
                        (defined($metacache{$uri.':'.$unikey.'.'.$subp})) {      $metacache{$uri.':'.$unikey.'.default'};
                          $metacache{$uri.':'.$unikey.'.'.$subp}=$value;      }
       }   }
                   }      }
               }   } else {
              } else {  
 #  #
 # This is not a package - some other kind of start tag  # This is not a package - some other kind of start tag
 #   #
               my $entry=$token->[1];      my $entry=$token->[1];
               my $unikey;      my $unikey;
               if ($entry eq 'import') {      if ($entry eq 'import') {
                  $unikey='';   $unikey='';
               } else {      } else {
                  $unikey=$entry;   $unikey=$entry;
       }      }
               if ($prefix) {      $unikey.=&add_prefix_and_part($prefix,$token->[2]->{'part'});
   $unikey.=$prefix;  
               } else {      if (defined($token->[2]->{'id'})) { 
                 if (defined($token->[2]->{'part'})) {    $unikey.='_'.$token->[2]->{'id'}; 
                    $unikey.='_'.$token->[2]->{'part'};       }
         }  
       }  
               if (defined($token->[2]->{'id'})) {   
                  $unikey.='_'.$token->[2]->{'id'};   
       }  
   
              if ($entry eq 'import') {      if ($entry eq 'import') {
 #  #
 # Importing a library here  # Importing a library here
 #                  #
                  if ($depthcount<20) {   if ($depthcount<20) {
      my $location=$parser->get_text('/import');      my $location=$parser->get_text('/import');
      my $dir=$filename;      my $dir=$filename;
      $dir=~s|[^/]*$||;      $dir=~s|[^/]*$||;
      $location=&filelocation($dir,$location);      $location=&filelocation($dir,$location);
      foreach (sort(split(/\,/,&metadata($uri,'keys',      foreach (sort(split(/\,/,&metadata($uri,'keys',
  $location,$unikey,         $location,$unikey,
  $depthcount+1)))) {         $depthcount+1)))) {
                          $metathesekeys{$_}=1;   $metathesekeys{$_}=1;
      }      }
  }   }
              } else {       } else { 
   
               if (defined($token->[2]->{'name'})) {    if (defined($token->[2]->{'name'})) { 
                  $unikey.='_'.$token->[2]->{'name'};       $unikey.='_'.$token->[2]->{'name'}; 
       }   }
               $metathesekeys{$unikey}=1;   $metathesekeys{$unikey}=1;
               foreach (@{$token->[3]}) {   foreach (@{$token->[3]}) {
   $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};      $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};
               }   }
               unless (   my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));
                  $metacache{$uri.':'.$unikey}=&HTML::Entities::decode($parser->get_text('/'.$entry))   my $default=$metacache{$uri.':'.$unikey.'.default'};
       ) { $metacache{$uri.':'.$unikey}=   if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) {
       $metacache{$uri.':'.$unikey.'.default'};   # only ws inside the tag, and not in default, so use default
       }   # as value
       $metacache{$uri.':'.$unikey}=$default;
    } else {
     # either something interesting inside the tag or default
                     # uninteresting
       $metacache{$uri.':'.$unikey}=$internaltext;
    }
 # end of not-a-package not-a-library import  # end of not-a-package not-a-library import
    }      }
 # end of not-a-package start tag  # end of not-a-package start tag
   }   }
 # the next is the end of "start tag"  # the next is the end of "start tag"
  }      }
        }   }
        $metacache{$uri.':keys'}=join(',',keys %metathesekeys);  # are there custom rights to evaluate
    if ($metacache{$uri.':copyright'} eq 'custom') {
   
       #
       # Importing a rights file here
       #
       unless ($depthcount) {
    my $location=$metacache{$uri.':customdistributionfile'};
    my $dir=$filename;
    $dir=~s|[^/]*$||;
    $location=&filelocation($dir,$location);
    foreach (sort(split(/\,/,&metadata($uri,'keys',
      $location,'_rights',
      $depthcount+1)))) {
       $metathesekeys{$_}=1;
    }
       }
    }
    $metacache{$uri.':keys'}=join(',',keys %metathesekeys);
  &metadata_generate_part0(\%metathesekeys,\%metacache,$uri);   &metadata_generate_part0(\%metathesekeys,\%metacache,$uri);
        $metacache{$uri.':allpossiblekeys'}=join(',',keys %metathesekeys);   $metacache{$uri.':allpossiblekeys'}=join(',',keys %metathesekeys);
        $metacache{$uri.':cachedtimestamp'}=time;   $metacache{$uri.':cachedtimestamp'}=time;
 # this is the end of "was not already recently cached  # this is the end of "was not already recently cached
     }      }
     return $metacache{$uri.':'.$what};      return $metacache{$uri.':'.$what};
Line 3077  sub metadata_generate_part0 { Line 3647  sub metadata_generate_part0 {
  if ($metakey=~/^parameter\_(.*)/) {   if ($metakey=~/^parameter\_(.*)/) {
   my $part=$$metacache{$uri.':'.$metakey.'.part'};    my $part=$$metacache{$uri.':'.$metakey.'.part'};
   my $name=$$metacache{$uri.':'.$metakey.'.name'};    my $name=$$metacache{$uri.':'.$metakey.'.name'};
   if (! exists($$metadata{'parameter_0_'.$name})) {    if (! exists($$metadata{'parameter_0_'.$name.'.name'})) {
     $allnames{$name}=$part;      $allnames{$name}=$part;
   }    }
  }   }
Line 3107  sub gettitle { Line 3677  sub gettitle {
  unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; }   unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; }
         return &metadata($urlsymb,'title');           return &metadata($urlsymb,'title'); 
     }      }
     if ($titlecache{$symb}) { return $titlecache{$symb}; }      if ($titlecache{$symb}) {
    if (time < ($titlecache{$symb}[1] + 600)) {
       return $titlecache{$symb}[0];
    } else {
       delete($titlecache{$symb});
    }
       }
     my ($map,$resid,$url)=split(/\_\_\_/,$symb);      my ($map,$resid,$url)=split(/\_\_\_/,$symb);
     my $title='';      my $title='';
     my %bighash;      my %bighash;
Line 3117  sub gettitle { Line 3693  sub gettitle {
         $title=$bighash{'title_'.$mapid.'.'.$resid};          $title=$bighash{'title_'.$mapid.'.'.$resid};
         untie %bighash;          untie %bighash;
     }      }
       $title=~s/\&colon\;/\:/gs;
     if ($title) {      if ($title) {
         $titlecache{$symb}=$title;          $titlecache{$symb}=[$title,time];
         return $title;          return $title;
     } else {      } else {
  return &metadata($urlsymb,'title');   return &metadata($urlsymb,'title');
Line 3290  sub numval { Line 3867  sub numval {
     $txt=~tr/u-z/0-5/;      $txt=~tr/u-z/0-5/;
     $txt=~s/\D//g;      $txt=~s/\D//g;
     return int($txt);      return int($txt);
 }      }
   
   sub latest_rnd_algorithm_id {
       return '64bit';
   }
   
 sub rndseed {  sub rndseed {
     my ($symb,$courseid,$domain,$username)=@_;      my ($symb,$courseid,$domain,$username)=@_;
   
       my ($wsymb,$wcourseid,$wdomain,$wusername)=&Apache::lonxml::whichuser();
     if (!$symb) {      if (!$symb) {
       unless ($symb=&symbread()) { return time; }   unless ($symb=$wsymb) { return time; }
       }
       if (!$courseid) { $courseid=$wcourseid; }
       if (!$domain) { $domain=$wdomain; }
       if (!$username) { $username=$wusername }
       my $which=$ENV{"course.$courseid.rndseed"};
       my $CODE=$ENV{'scantron.CODE'};
       if (defined($CODE)) {
    &rndseed_CODE_64bit($symb,$courseid,$domain,$username);
       } elsif ($which eq '64bit') {
    return &rndseed_64bit($symb,$courseid,$domain,$username);
       }
       return &rndseed_32bit($symb,$courseid,$domain,$username);
   }
   
   sub rndseed_32bit {
       my ($symb,$courseid,$domain,$username)=@_;
       {
    use integer;
    my $symbchck=unpack("%32C*",$symb) << 27;
    my $symbseed=numval($symb) << 22;
    my $namechck=unpack("%32C*",$username) << 17;
    my $nameseed=numval($username) << 12;
    my $domainseed=unpack("%32C*",$domain) << 7;
    my $courseseed=unpack("%32C*",$courseid);
    my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;
    #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
    #&Apache::lonxml::debug("rndseed :$num:$symb");
    return $num;
       }
   }
   
   sub rndseed_64bit {
       my ($symb,$courseid,$domain,$username)=@_;
       {
    use integer;
    my $symbchck=unpack("%32S*",$symb) << 21;
    my $symbseed=numval($symb) << 10;
    my $namechck=unpack("%32S*",$username);
   
    my $nameseed=numval($username) << 21;
    my $domainseed=unpack("%32S*",$domain) << 10;
    my $courseseed=unpack("%32S*",$courseid);
   
    my $num1=$symbchck+$symbseed+$namechck;
    my $num2=$nameseed+$domainseed+$courseseed;
    #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
    #&Apache::lonxml::debug("rndseed :$num:$symb");
    return "$num1,$num2";
     }      }
     if (!$courseid) { $courseid=$ENV{'request.course.id'};}  }
     if (!$domain) {$domain=$ENV{'user.domain'};}  
     if (!$username) {$username=$ENV{'user.name'};}  sub rndseed_CODE_64bit {
       my ($symb,$courseid,$domain,$username)=@_;
     {      {
       use integer;   use integer;
       my $symbchck=unpack("%32C*",$symb) << 27;   my $symbchck=unpack("%32S*",$symb) << 16;
       my $symbseed=numval($symb) << 22;   my $symbseed=numval($symb);
       my $namechck=unpack("%32C*",$username) << 17;   my $CODEseed=numval($ENV{'scantron.CODE'}) << 16;
       my $nameseed=numval($username) << 12;   my $courseseed=unpack("%32S*",$courseid);
       my $domainseed=unpack("%32C*",$domain) << 7;   my $num1=$symbseed+$CODEseed;
       my $courseseed=unpack("%32C*",$courseid);   my $num2=$courseseed+$symbchck;
       my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;   #&Apache::lonxml::debug("$symbseed:$CODEseed|$courseseed:$symbchck");
       #uncommenting these lines can break things!   #&Apache::lonxml::debug("rndseed :$num1:$num2:$symb");
       #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");   return "$num1,$num2";
       #&Apache::lonxml::debug("rndseed :$num:$symb");      }
       return $num;  }
   
   sub setup_random_from_rndseed {
       my ($rndseed)=@_;
       if ($rndseed =~/,/) {
    my ($num1,$num2)=split(/,/,$rndseed);
    &Math::Random::random_set_seed(abs($num1),abs($num2));
       } else {
    &Math::Random::random_set_seed_from_phrase($rndseed);
     }      }
 }  }
   
Line 3438  sub goodbye { Line 4078  sub goodbye {
    &logthis("Starting Shut down");     &logthis("Starting Shut down");
    &flushcourselogs();     &flushcourselogs();
    &logthis("Shutting down");     &logthis("Shutting down");
      return DONE;
 }  }
   
 BEGIN {  BEGIN {
Line 3466  BEGIN { Line 4107  BEGIN {
     }      }
 }  }
   
   # ------------------------------------------------------------ Read domain file
   {
       my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.
                               '/domain.tab');
       %domaindescription = ();
       %domain_auth_def = ();
       %domain_auth_arg_def = ();
       if ($fh) {
          while (<$fh>) {
              next if (/^(\#|\s*$)/);
   #           next if /^\#/;
              chomp;
              my ($domain, $domain_description, $def_auth, $def_auth_arg)
                  = split(/:/,$_,4);
              $domain_auth_def{$domain}=$def_auth;
              $domain_auth_arg_def{$domain}=$def_auth_arg;
              $domaindescription{$domain}=$domain_description;
   #          &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}");
   #          &logthis("Domain.tab: $domain ".$domaindescription{$domain} );
          }
       }
   }
   
   
 # ------------------------------------------------------------- Read hosts file  # ------------------------------------------------------------- Read hosts file
 {  {
     my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab");      my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab");
   
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
          next if ($configline =~ /^(\#|\s*$)/);
        chomp($configline);         chomp($configline);
        my ($id,$domain,$role,$name,$ip,$domdescr)=split(/:/,$configline);         my ($id,$domain,$role,$name,$ip,$domdescr)=split(/:/,$configline);
        if ($id && $domain && $role && $name && $ip) {         if ($id && $domain && $role && $name && $ip) {
Line 3478  BEGIN { Line 4144  BEGIN {
  $hostdom{$id}=$domain;   $hostdom{$id}=$domain;
  $hostip{$id}=$ip;   $hostip{$id}=$ip;
  $iphost{$ip}=$id;   $iphost{$ip}=$id;
  if ($domdescr) { $domaindescription{$domain}=$domdescr; }  
  if ($role eq 'library') { $libserv{$id}=$name; }   if ($role eq 'library') { $libserv{$id}=$name; }
        } else {         } else {
  if ($configline) {   if ($configline) {
Line 3540  BEGIN { Line 4205  BEGIN {
     }      }
 }  }
   
   # ------------- set up temporary directory
   {
       $tmpdir = $perlvar{'lonDaemons'}.'/tmp/';
   
   }
   
 %metacache=();  %metacache=();
   
 $processmarker='_'.time.'_'.$perlvar{'lonHostID'};  $processmarker='_'.time.'_'.$perlvar{'lonHostID'};
Line 3589  being set. Line 4260  being set.
   
 =back  =back
   
 =head1 INTRODUCTION  =head1 OVERVIEW
   
 This module provides subroutines which interact with the  lonnet provides subroutines which interact with the
 lonc/lond (TCP) network layer of LON-CAPA. And Can be used to ask about   lonc/lond (TCP) network layer of LON-CAPA. They can be used to ask
 - classes  about classes, users, and resources.
 - users   
 - resources  
   
 For many of these objects you can also use this to store data about  For many of these objects you can also use this to store data about
 them or modify them in various ways.  them or modify them in various ways.
   
 This is part of the LearningOnline Network with CAPA project  =head2 Symbs
 described at http://www.lon-capa.org.  
   
 =head1 RETURN MESSAGES  To identify a specific instance of a resource, LON-CAPA uses symbols
   or "symbs"X<symb>. These identifiers are built from the URL of the
   map, the resource number of the resource in the map, and the URL of
   the resource itself. The latter is somewhat redundant, but might help
   if maps change.
   
 =over 4  An example is
   
 =item *   msu/korte/parts/part1.sequence___19___msu/korte/tests/part12.problem
   
 con_lost : unable to contact remote host  The respective map entry is
   
 =item *   <resource id="19" src="/res/msu/korte/tests/part12.problem"
     title="Problem 2">
    </resource>
   
 con_delayed : unable to contact remote host, message will be delivered  Symbs are used by the random number generator, as well as to store and
 when the connection is brought back up  restore data specific to a certain instance of for example a problem.
   
 =item *  =head2 Storing And Retrieving Data
   
 con_failed : unable to contact remote host and unable to save message  X<store()>X<cstore()>X<restore()>Three of the most important functions
 for later delivery  in C<lonnet.pm> are C<&Apache::lonnet::cstore()>,
   C<&Apache::lonnet:restore()>, and C<&Apache::lonnet::store()>, which
   is is the non-critical message twin of cstore. These functions are for
   handlers to store a perl hash to a user's permanent data space in an
   easy manner, and to retrieve it again on another call. It is expected
   that a handler would use this once at the beginning to retrieve data,
   and then again once at the end to send only the new data back.
   
 =item *  The data is stored in the user's data directory on the user's
   homeserver under the ID of the course.
   
 error: : an error a occured, a description of the error follows the :  The hash that is returned by restore will have all of the previous
   value for all of the elements of the hash.
   
 =item *  Example:
   
    #creating a hash
    my %hash;
    $hash{'foo'}='bar';
   
    #storing it
    &Apache::lonnet::cstore(\%hash);
   
    #changing a value
    $hash{'foo'}='notbar';
   
    #adding a new value
    $hash{'bar'}='foo';
    &Apache::lonnet::cstore(\%hash);
   
    #retrieving the hash
    my %history=&Apache::lonnet::restore();
   
    #print the hash
    foreach my $key (sort(keys(%history))) {
      print("\%history{$key} = $history{$key}");
    }
   
   Will print out:
   
    %history{1:foo} = bar
    %history{1:keys} = foo:timestamp
    %history{1:timestamp} = 990455579
    %history{2:bar} = foo
    %history{2:foo} = notbar
    %history{2:keys} = foo:bar:timestamp
    %history{2:timestamp} = 990455580
    %history{bar} = foo
    %history{foo} = notbar
    %history{timestamp} = 990455580
    %history{version} = 2
   
   Note that the special hash entries C<keys>, C<version> and
   C<timestamp> were added to the hash. C<version> will be equal to the
   total number of versions of the data that have been stored. The
   C<timestamp> attribute will be the UNIX time the hash was
   stored. C<keys> is available in every historical section to list which
   keys were added or changed at a specific historical revision of a
   hash.
   
   B<Warning>: do not store the hash that restore returns directly. This
   will cause a mess since it will restore the historical keys as if the
   were new keys. I.E. 1:foo will become 1:1:foo etc.
   
   Calling convention:
   
    my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname,$home);
    &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname,$home);
   
   For more detailed information, see lonnet specific documentation.
   
   =head1 RETURN MESSAGES
   
   =over 4
   
 no_such_host : unable to fund a host associated with the user/domain  =item * B<con_lost>: unable to contact remote host
   
   =item * B<con_delayed>: unable to contact remote host, message will be delivered
   when the connection is brought back up
   
   =item * B<con_failed>: unable to contact remote host and unable to save message
   for later delivery
   
   =item * B<error:>: an error a occured, a description of the error follows the :
   
   =item * B<no_such_host>: unable to fund a host associated with the user/domain
 that was requested  that was requested
   
 =back  =back
Line 3638  that was requested Line 4389  that was requested
   
 =over 4  =over 4
   
 =item *  =item * 
   X<appenv()>
 appenv(%hash) : the value of %hash is written to the user envirnoment  B<appenv(%hash)>: the value of %hash is written to
 file, and will be restored for each access this user makes during this  the user envirnoment file, and will be restored for each access this
 session, also modifies the %ENV for the current process  user makes during this session, also modifies the %ENV for the current
   process
   
 =item *  =item *
   X<delenv()>
 delenv($regexp) : removes all items from the session environment file that matches the regular expression in $regexp. The values are also delted from the current processes %ENV.  B<delenv($regexp)>: removes all items from the session
   environment file that matches the regular expression in $regexp. The
   values are also delted from the current processes %ENV.
   
 =back  =back
   
Line 3655  delenv($regexp) : removes all items from Line 4409  delenv($regexp) : removes all items from
 =over 4  =over 4
   
 =item *  =item *
   X<queryauthenticate()>
 queryauthenticate($uname,$udom) : try to determine user's current  B<queryauthenticate($uname,$udom)>: try to determine user's current 
 authentication scheme  authentication scheme
   
 =item *  =item *
   X<authenticate()>
 authenticate($uname,$upass,$udom) : try to authenticate user from domain's lib  B<authenticate($uname,$upass,$udom)>: try to
 servers (first use the current one), $upass should be the users password  authenticate user from domain's lib servers (first use the current
   one). C<$upass> should be the users password.
   
 =item *  =item *
   X<homeserver()>
 homeserver($uname,$udom) : find the server which has the user's  B<homeserver($uname,$udom)>: find the server which has
 directory and files (there must be only one), this caches the answer,  the user's directory and files (there must be only one), this caches
 and also caches if there is a borken connection.  the answer, and also caches if there is a borken connection.
   
 =item *  =item *
   X<idget()>
 idget($udom,@ids) : find the usernames behind a list of IDs (IDs are a  B<idget($udom,@ids)>: find the usernames behind a list of IDs
 unique resource in a domain, there must be only 1 ID per username, and  (IDs are a unique resource in a domain, there must be only 1 ID per
 only 1 username per ID in a specific domain) (returns hash:  username, and only 1 username per ID in a specific domain) (returns
 id=>name,id=>name)  hash: id=>name,id=>name)
   
 =item *  =item *
   X<idrget()>
 idrget($udom,@unames) : find the IDs behind a list of usernames (returns hash:  B<idrget($udom,@unames)>: find the IDs behind a list of
 name=>id,name=>id)  usernames (returns hash: name=>id,name=>id)
   
 =item *  =item *
   X<idput()>
 idput($udom,%ids) : store away a list of names and associated IDs  B<idput($udom,%ids)>: store away a list of names and associated IDs
   
 =item *  =item *
   X<rolesinit()>
 rolesinit($udom,$username,$authhost) : get user privileges  B<rolesinit($udom,$username,$authhost)>: get user privileges
   
 =item *  =item *
   X<usection()>
 usection($udom,$uname,$cname) : finds the section of student in the  B<usection($udom,$uname,$cname)>: finds the section of student in the
 course $cname, return section name/number or '' for "not in course"  course $cname, return section name/number or '' for "not in course"
 and '-1' for "no section"  and '-1' for "no section"
   
 =item *  =item *
   X<userenvironment()>
 userenvironment($udom,$uname,@what) : gets the values of the keys  B<userenvironment($udom,$uname,@what)>: gets the values of the keys
 passed in @what from the requested user's environment, returns a hash  passed in @what from the requested user's environment, returns a hash
   
 =back  =back
Removed from v.1.301  
changed lines
  Added in v.1.396

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