[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.344 and 1.386

version 1.344, 2003/03/22 02:13:08 version 1.386, 2003/07/03 19:26:21
Line 74  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      %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache 
    %domaindescription %domain_auth_def %domain_auth_arg_def $tmpdir);     %domaindescription %domain_auth_def %domain_auth_arg_def $tmpdir);
 use IO::Socket;  use IO::Socket;
 use GDBM_File;  use GDBM_File;
Line 243  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 347  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 373  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 641  sub idput {
 # --------------------------------------------------- Assign a key to a student  # --------------------------------------------------- Assign a key to a student
   
 sub assign_access_key {  sub assign_access_key {
     my ($ckey,$cdom,$cnum,$udom,$uname)=@_;  #
   # a valid key looks like uname:udom#comments
   # comments are being appended
   #
       my ($ckey,$cdom,$cnum,$udom,$uname,$logentry)=@_;
     $cdom=      $cdom=
    $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));     $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));
     $cnum=      $cnum=
    $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));     $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));
     $udom=$ENV{'user.name'} unless (defined($udom));      $udom=$ENV{'user.name'} unless (defined($udom));
     $uname=$ENV{'user.domain'} unless (defined($uname));      $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  # ------------------------------------------------------ Generate a set of keys
   
 sub generate_access_keys {  sub generate_access_keys {
     my ($number,$cdom,$cnum)=@_;      my ($number,$cdom,$cnum,$logentry)=@_;
     $cdom=      $cdom=
    $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));     $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));
     $cnum=      $cnum=
    $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));     $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));
       unless (&allowed('mky',$cdom)) { return 0; }
     unless (($cdom) && ($cnum)) { return 0; }      unless (($cdom) && ($cnum)) { return 0; }
     if ($number>10000) { return 0; }      if ($number>10000) { return 0; }
     sleep(2); # make sure don't get same seed twice      sleep(2); # make sure don't get same seed twice
Line 623  sub generate_access_keys { Line 736  sub generate_access_keys {
        if ($existing{$newkey}) {         if ($existing{$newkey}) {
            $i--;             $i--;
        } else {         } else {
   if (&put('accesskeys',{ $newkey => time() },$cdom,$cnum) eq 'ok') {    if (&put('accesskeys',
                 { $newkey => '# generated '.localtime().
                              ' by '.$ENV{'user.name'}.'@'.$ENV{'user.domain'}.
                              '; '.$logentry },
      $cdom,$cnum) eq 'ok') {
               $total++;                $total++;
   }    }
        }         }
Line 643  sub validate_access_key { Line 760  sub validate_access_key {
    $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));     $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));
     $udom=$ENV{'user.name'} unless (defined($udom));      $udom=$ENV{'user.name'} unless (defined($udom));
     $uname=$ENV{'user.domain'} unless (defined($uname));      $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
Line 863  sub repcopy { Line 982  sub repcopy {
   
 # ------------------------------------------------ Get server side include body  # ------------------------------------------------ Get server side include body
 sub ssi_body {  sub ssi_body {
     my $filelink=shift;      my ($filelink,%form)=@_;
     my $output=($filelink=~/^http\:/?&externalssi($filelink):      my $output=($filelink=~/^http\:/?&externalssi($filelink):
                                      &ssi($filelink));                                       &ssi($filelink,%form));
     $output=~s/^.*\<body[^\>]*\>//si;      $output=~s/^.*\<body[^\>]*\>//si;
     $output=~s/\<\/body\s*\>.*$//si;      $output=~s/\<\/body\s*\>.*$//si;
     $output=~      $output=~
Line 998  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 1014  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});
           }    
       }
   #
   # Write course id database (reverse lookup) to homeserver of courses 
   # Is used in pickcourse
   #
       foreach (keys %courseidbuffer) {
           &courseidput($hostdom{$_},$courseidbuffer{$_},$_);
     }      }
     &logthis('Flushing access logs');  #
   # 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 1025  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 1033  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 1073  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 1402  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 1678  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 1689  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 $roledef=
   reply("get:$rdomain:$rauthor:roles:rolesdef_$rrole",      reply("get:$rdomain:$rauthor:roles:rolesdef_$rrole",
                                 $homsvr);    $homsvr);
                       if (($roledef ne 'con_lost') && ($roledef ne '')) {   if (($roledef ne 'con_lost') && ($roledef ne '')) {
                          my ($syspriv,$dompriv,$coursepriv)=      my ($syspriv,$dompriv,$coursepriv)=
      split(/\_/,unescape($roledef));   split(/\_/,unescape($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 2393  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)) {   unless (&allowed('ccr',$url)) {
Line 2406  sub assignrole { Line 2661  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 2424  sub assignrole { Line 2679  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 2501  sub modifyuser { Line 2774  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 2511  sub modifyuser { Line 2784  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));
Line 2527  sub modifyuser { Line 2801  sub modifyuser {
     } else {      } else {
         %names = @tmp;          %names = @tmp;
     }      }
     if ($first)  { $names{'firstname'}  = $first; }      if (defined($first))  { $names{'firstname'}  = $first; }
     if ($middle) { $names{'middlename'} = $middle; }      if (defined($middle)) { $names{'middlename'} = $middle; }
     if ($last)   { $names{'lastname'}   = $last; }      if (defined($last))   { $names{'lastname'}   = $last; }
     if ($gene)   { $names{'generation'} = $gene; }      if (defined($gene))   { $names{'generation'} = $gene; }
     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 2670  sub createcourse { Line 2944  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 2698  ENDINITMAP Line 2977  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 2805  sub GetFileTimestamp { Line 3085  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 2906  sub courseresdata { Line 3186  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}+1800) > 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)=@_;
   
     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'};
Line 2938  sub EXT { Line 3244  sub EXT {
     if (defined($Apache::lonhomework::parsing_a_problem)) {      if (defined($Apache::lonhomework::parsing_a_problem)) {
  return $Apache::lonhomework::history{$qualifierrest};   return $Apache::lonhomework::history{$qualifierrest};
     } else {      } else {
  my %restored=&restore($symbparm,$courseid,$udom,$uname);   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};   return $restored{$qualifierrest};
     }      }
 # ----------------------------------------------------------------- user.access  # ----------------------------------------------------------------- user.access
Line 2951  sub EXT { Line 3262  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 2975  sub EXT { Line 3290  sub EXT {
             return $uname;              return $uname;
 # ---------------------------------------------------- Any other user namespace  # ---------------------------------------------------- Any other user namespace
         } else {          } else {
             my %reply=&get($space,[$qualifierrest],$udom,$uname);      my %reply;
             return $reply{$qualifierrest};      if (!$publicuser) {
    %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 2995  sub EXT { Line 3314  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'}) {   if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) {
   
     #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;      #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
   
Line 3012  sub EXT { Line 3331  sub EXT {
  ($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 3024  sub EXT { Line 3347  sub EXT {
     my $courselevelm=$courseid.'.'.$mapparm;      my $courselevelm=$courseid.'.'.$mapparm;
   
 # ----------------------------------------------------------- first, check user  # ----------------------------------------------------------- first, check user
     #most student don't have any data set, check if there is some data      #most student don\'t have any data set, check if there is some data
             #every thirty minutes              #every thirty minutes
     if (!      if (! &EXT_cache_status($udom,$uname)) {
  (exists($ENV{'cache.studentresdata'})  
     && (($ENV{'cache.studentresdata'}+1800) > time))) {  
  my %resourcedata=&get('resourcedata',   my %resourcedata=&get('resourcedata',
       [$courselevelr,$courselevelm,$courselevel],        [$courselevelr,$courselevelm,$courselevel],
       $udom,$uname);        $udom,$uname);
Line 3047  sub EXT { Line 3368  sub EXT {
  $uname." at ".$udom.": ".   $uname." at ".$udom.": ".
  $tmp."</font>");   $tmp."</font>");
     } elsif ($tmp=~/error:No such file/) {      } elsif ($tmp=~/error:No such file/) {
  $ENV{'cache.studentresdata'}=time;                          &EXT_cache_set($udom,$uname);
  &appenv(('cache.studentresdata'=>  
  $ENV{'cache.studentresdata'}));  
     } elsif ($tmp =~ /^(con_lost|no_such_host)/) {      } elsif ($tmp =~ /^(con_lost|no_such_host)/) {
  return $tmp;   return $tmp;
     }      }
Line 3169  sub metadata { Line 3488  sub metadata {
         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'})) {
Line 3195  sub metadata { Line 3515  sub metadata {
  $value.=' [Part: '.$part.']';   $value.=' [Part: '.$part.']';
     }      }
     my $unikey='parameter'.$keyroot.'_'.$name;      my $unikey='parameter'.$keyroot.'_'.$name;
     if ($subp eq 'default') { $unikey='parameter_0_'.$name; }      if ($subp eq 'default') {
     $metathesekeys{$unikey}=1;   $unikey='parameter_0_'.$name;
     $metacache{$uri.':'.$unikey.'.part'}=$part;   $metacache{$uri.':'.$unikey.'.part'}='0';
       } else {
    $metacache{$uri.':'.$unikey.'.part'}=$part;
    $metathesekeys{$unikey}=1;
       }
     unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) {      unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) {
  $metacache{$uri.':'.$unikey.'.'.$subp}=$value;   $metacache{$uri.':'.$unikey.'.'.$subp}=$value;
     }      }
     if (defined($metacache{$uri.':'.$unikey.'.default'})) {      if (defined($metacache{$uri.':'.$unikey.'.default'})) {
  $metacache{$uri.':'.$unikey}=   $metacache{$uri.':'.$unikey}=
     $metacache{$uri.':'.$unikey.'.default'}      $metacache{$uri.':'.$unikey.'.default'};
  }      }
  }   }
     }      }
  } else {   } else {
Line 3300  sub metadata_generate_part0 { Line 3624  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 3330  sub gettitle { Line 3654  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 3340  sub gettitle { Line 3670  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 3513  sub numval { Line 3844  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);
     }      }
     if (!$courseid) { $courseid=$ENV{'request.course.id'};}      return &rndseed_32bit($symb,$courseid,$domain,$username);
     if (!$domain) {$domain=$ENV{'user.domain'};}  }
     if (!$username) {$username=$ENV{'user.name'};}  
   sub rndseed_32bit {
       my ($symb,$courseid,$domain,$username)=@_;
     {      {
       use integer;   use integer;
       my $symbchck=unpack("%32C*",$symb) << 27;   my $symbchck=unpack("%32C*",$symb) << 27;
       my $symbseed=numval($symb) << 22;   my $symbseed=numval($symb) << 22;
       my $namechck=unpack("%32C*",$username) << 17;   my $namechck=unpack("%32C*",$username) << 17;
       my $nameseed=numval($username) << 12;   my $nameseed=numval($username) << 12;
       my $domainseed=unpack("%32C*",$domain) << 7;   my $domainseed=unpack("%32C*",$domain) << 7;
       my $courseseed=unpack("%32C*",$courseid);   my $courseseed=unpack("%32C*",$courseid);
       my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;   my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;
       #uncommenting these lines can break things!   #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
       #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");   #&Apache::lonxml::debug("rndseed :$num:$symb");
       #&Apache::lonxml::debug("rndseed :$num:$symb");   return $num;
       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";
       }
   }
   
   sub rndseed_CODE_64bit {
       my ($symb,$courseid,$domain,$username)=@_;
       {
    use integer;
    my $symbchck=unpack("%32S*",$symb) << 16;
    my $symbseed=numval($symb);
    my $CODEseed=numval($ENV{'scantron.CODE'}) << 16;
    my $courseseed=unpack("%32S*",$courseid);
    my $num1=$symbseed+$CODEseed;
    my $num2=$courseseed+$symbchck;
    #&Apache::lonxml::debug("$symbseed:$CODEseed|$courseseed:$symbchck");
    #&Apache::lonxml::debug("rndseed :$num1:$num2:$symb");
    return "$num1,$num2";
       }
   }
   
   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 3661  sub goodbye { Line 4055  sub goodbye {
    &logthis("Starting Shut down");     &logthis("Starting Shut down");
    &flushcourselogs();     &flushcourselogs();
    &logthis("Shutting down");     &logthis("Shutting down");
      return DONE;
 }  }
   
 BEGIN {  BEGIN {
Removed from v.1.344  
changed lines
  Added in v.1.386

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