[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.495 and 1.511

version 1.495, 2004/05/07 17:17:50 version 1.511, 2004/06/17 18:31:25
Line 434  sub overloaderror { Line 434  sub overloaderror {
     if ($overload>0) {      if ($overload>0) {
  $r->err_headers_out->{'Retry-After'}=$overload;   $r->err_headers_out->{'Retry-After'}=$overload;
         $r->log_error('Overload of '.$overload.' on '.$checkserver);          $r->log_error('Overload of '.$overload.' on '.$checkserver);
         return 413;          return 409;
     }          }    
     return '';      return '';
 }  }
Line 642  sub assign_access_key { Line 642  sub assign_access_key {
 # a valid key looks like uname:udom#comments  # a valid key looks like uname:udom#comments
 # comments are being appended  # comments are being appended
 #  #
     my ($ckey,$cdom,$cnum,$udom,$uname,$logentry)=@_;      my ($ckey,$kdom,$knum,$cdom,$cnum,$udom,$uname,$logentry)=@_;
       $kdom=
      $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($kdom));
       $knum=
      $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($knum));
     $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);      my %existing=&get('accesskeys',[$ckey],$kdom,$knum);
     if (($existing{$ckey}=~/^\#(.*)$/) || # - new key      if (($existing{$ckey}=~/^\#(.*)$/) || # - new key
         ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#(.*)$/)) {           ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#(.*)$/)) { 
                                                   # assigned to this person                                                    # assigned to this person
Line 658  sub assign_access_key { Line 662  sub assign_access_key {
                                                   # the first time around                                                    # the first time around
 # ready to assign  # ready to assign
         $logentry=$1.'; '.$logentry;          $logentry=$1.'; '.$logentry;
         if (&put('accesskey',{$ckey=>$uname.':'.$udom.'#'.$logentry},          if (&put('accesskeys',{$ckey=>$uname.':'.$udom.'#'.$logentry},
                                                  $cdom,$cnum) eq 'ok') {                                                   $kdom,$knum) eq 'ok') {
 # key now belongs to user  # key now belongs to user
     my $envkey='key.'.$cdom.'_'.$cnum;      my $envkey='key.'.$cdom.'_'.$cnum;
             if (&put('environment',{$envkey => $ckey}) eq 'ok') {              if (&put('environment',{$envkey => $ckey}) eq 'ok') {
Line 755  sub validate_access_key { Line 759  sub validate_access_key {
    $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.domain'} unless (defined($udom));
     $uname=$ENV{'user.domain'} unless (defined($uname));      $uname=$ENV{'user.name'} unless (defined($uname));
     my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);      my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
     return ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#/);      return ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#/);
 }  }
Line 1178  sub allowuploaded { Line 1182  sub allowuploaded {
     &Apache::lonnet::appenv(%httpref);      &Apache::lonnet::appenv(%httpref);
 }  }
   
 sub tokenwrapper {  
     &FIXME_blow_up;  
 }  
   
 # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course  # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course
 # input: action, courseID, current domain, home server for course, intended  # input: action, courseID, current domain, home server for course, intended
 #        path to file, source of file.  #        path to file, source of file.
Line 1325  sub finishuserfileupload { Line 1325  sub finishuserfileupload {
     }      }
 # Save the file  # Save the file
     {      {
  &Apache::lonnet::logthis("Saving to $filepath $file");   #&Apache::lonnet::logthis("Saving to $filepath $file");
        open(my $fh,'>'.$filepath.'/'.$file);         open(my $fh,'>'.$filepath.'/'.$file);
        print $fh $ENV{'form.'.$formname};         print $fh $ENV{'form.'.$formname};
        close($fh);         close($fh);
Line 1615  sub courseidput { Line 1615  sub courseidput {
 }  }
   
 sub courseiddump {  sub courseiddump {
     my ($domfilter,$descfilter,$sincefilter)=@_;      my ($domfilter,$descfilter,$sincefilter,$hostidflag,$hostidref)=@_;
     my %returnhash=();      my %returnhash=();
     unless ($domfilter) { $domfilter=''; }      unless ($domfilter) { $domfilter=''; }
     foreach my $tryserver (keys %libserv) {      foreach my $tryserver (keys %libserv) {
  if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) {          if ( ($hostidflag == 1 && grep/^$tryserver$/,@{$hostidref}) || (!defined($hostidflag)) ) {
     foreach (      if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) {
              split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.          foreach (
                    split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.
        $sincefilter.':'.&escape($descfilter),         $sincefilter.':'.&escape($descfilter),
                                $tryserver))) {                                 $tryserver))) {
  my ($key,$value)=split(/\=/,$_);      my ($key,$value)=split(/\=/,$_);
                 if (($key) && ($value)) {                      if (($key) && ($value)) {
     $returnhash{&unescape($key)}=&unescape($value);          $returnhash{&unescape($key)}=&unescape($value);
                       }
                 }                  }
             }              }
   
         }          }
     }      }
     return %returnhash;      return %returnhash;
Line 1638  sub courseiddump { Line 1639  sub courseiddump {
 #  #
 # ----------------------------------------------------------- Check out an item  # ----------------------------------------------------------- Check out an item
   
   sub get_first_access {
       my ($type,$argsymb)=@_;
       my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();
       if ($argsymb) { $symb=$argsymb; }
       my ($map,$id,$res)=&decode_symb($symb);
       if ($type eq 'map') { $res=$map; }
       my %times=&get('firstaccesstimes',[$res],$udom,$uname);
       return $times{$res};
   }
   
   sub set_first_access {
       my ($type)=@_;
       my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();
       my ($map,$id,$res)=&decode_symb($symb);
       if ($type eq 'map') { $res=$map; }
       my $firstaccess=&get_first_access($type);
       if (!$firstaccess) {
    return &put('firstaccesstimes',{$res=>time},$udom,$uname);
       }
       return 'already_set';
   }
   
 sub checkout {  sub checkout {
     my ($symb,$tuname,$tudom,$tcrsid)=@_;      my ($symb,$tuname,$tudom,$tcrsid)=@_;
     my $now=time;      my $now=time;
Line 3031  sub log_query { Line 3054  sub log_query {
     return get_query_reply($queryid);      return get_query_reply($queryid);
 }  }
   
   # ------- Request retrieval of institutional classlists for course(s)
   
   sub fetch_enrollment_query {
       my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_;
       my $homeserver;
       if ($context eq 'automated') {
           $homeserver = $perlvar{'lonHostID'};
       } else {
           $homeserver = &homeserver($cnum,$dom);
       }
       my $host=$hostname{$homeserver};
       my $cmd = '';
       foreach (keys %{$affiliatesref}) {
           $cmd .= $_.'='.join(",",@{$$affiliatesref{$_}}).'%%';
       }
       $cmd =~ s/%%$//;
       $cmd = &escape($cmd);
       my $query = 'fetchenrollment';
       my $queryid=&reply("querysend:".$query.':'.$dom.':'.$ENV{'user.name'}.':'.$cmd,$homeserver);
       unless ($queryid=~/^\Q$host\E\_/) { return 'error: '.$queryid; }
       my $reply = &get_query_reply($queryid);
       unless ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
           unless ($homeserver eq $perlvar{'lonHostID'}) {
               my @responses = split/:/,$reply;
               my $pathname = $perlvar{'lonDaemons'}.'/tmp';
               foreach (@responses) {
                   my ($key,$value) = split/=/,$_;
                   $$replyref{$key} = $value;
                   if ($value > 0) {
                       foreach (@{$$affiliatesref{$key}}) {
                           my $filename = $dom.'_'.$key.'_'.$_.'_classlist.xml';
                           my $destname = $pathname.'/'.$filename;
                           my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver);
                           unless ($xml_classlist =~ /^error/) {
                               if ( open(FILE,">$destname") ) {
                                   print FILE &unescape($xml_classlist);
                                   close(FILE);
                               }
                           }
                       }
                   }
               }
           }
           return 'ok';
       }
       return 'error';
   }
   
 sub get_query_reply {  sub get_query_reply {
     my $queryid=shift;      my $queryid=shift;
     my $replyfile=$perlvar{'lonDaemons'}.'/tmp/'.$queryid;      my $replyfile=$perlvar{'lonDaemons'}.'/tmp/'.$queryid;
Line 3075  sub userlog_query { Line 3146  sub userlog_query {
     return &log_query($uname,$udom,'userlog',%filters);      return &log_query($uname,$udom,'userlog',%filters);
 }  }
   
   #--------- Call auto-enrollment subs in localenroll.pm for homeserver for course 
   
   sub auto_run {
       my ($cnum,$cdom) = @_;
       my $homeserver = &homeserver($cnum,$cdom);
       my $response = &reply('autorun:'.$cdom,$homeserver);
       return $response;
   }
                                                                                      
   sub auto_get_sections {
       my ($cnum,$cdom,$inst_coursecode) = @_;
       my $homeserver = &homeserver($cnum,$cdom);
       my @secs = ();
       my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));
       unless ($response eq 'refused') {
           @secs = split/:/,$response;
       }
       return @secs;
   }
                                                                                      
   sub auto_new_course {
       my ($cnum,$cdom,$inst_course_id,$owner) = @_;
       my $homeserver = &homeserver($cnum,$cdom);
       my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner,':'.$cdom,$homeserver));
       return $response;
   }
                                                                                      
   sub auto_validate_courseID {
       my ($cnum,$cdom,$inst_course_id) = @_;
       my $homeserver = &homeserver($cnum,$cdom);
       my $response=&unescape(&reply('autovalidatecourse:'.$inst_course_id.':'.$cdom,$homeserver));
       return $response;
   }
                                                                                      
   sub auto_create_password {
       my ($cnum,$cdom,$authparam) = @_;
       my $homeserver = &homeserver($cnum,$cdom); 
       my $create_passwd = 0;
       my $authchk = '';
       my $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver));
       if ($response eq 'refused') {
           $authchk = 'refused';
       } else {
           ($authparam,$create_passwd,$authchk) = split/:/,$response;
       }
       return ($authparam,$create_passwd,$authchk);
   }
   
 # ------------------------------------------------------------------ Plain Text  # ------------------------------------------------------------------ Plain Text
   
 sub plaintext {  sub plaintext {
Line 4251  sub symblist { Line 4370  sub symblist {
 # --------------------------------------------------------------- Verify a symb  # --------------------------------------------------------------- Verify a symb
   
 sub symbverify {  sub symbverify {
     my ($symb,$thisfn)=@_;      my ($symb,$thisurl)=@_;
       my $thisfn=$thisurl;
   # wrapper not part of symbs
       $thisfn=~s/^\/adm\/wrapper//;
     $thisfn=&declutter($thisfn);      $thisfn=&declutter($thisfn);
 # direct jump to resource in page or to a sequence - will construct own symbs  # direct jump to resource in page or to a sequence - will construct own symbs
     if ($thisfn=~/\.(page|sequence)$/) { return 1; }      if ($thisfn=~/\.(page|sequence)$/) { return 1; }
Line 4261  sub symbverify { Line 4383  sub symbverify {
     unless ($url eq $thisfn) { return 0; }      unless ($url eq $thisfn) { return 0; }
   
     $symb=&symbclean($symb);      $symb=&symbclean($symb);
       $thisurl=&deversion($thisurl);
     $thisfn=&deversion($thisfn);      $thisfn=&deversion($thisfn);
   
     my %bighash;      my %bighash;
Line 4268  sub symbverify { Line 4391  sub symbverify {
   
     if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',      if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
                             &GDBM_READER(),0640)) {                              &GDBM_READER(),0640)) {
         my $ids=$bighash{'ids_'.&clutter($thisfn)};          my $ids=$bighash{'ids_'.&clutter($thisurl)};
         unless ($ids) {           unless ($ids) { 
            $ids=$bighash{'ids_/'.$thisfn};             $ids=$bighash{'ids_/'.$thisurl};
         }          }
         if ($ids) {          if ($ids) {
 # ------------------------------------------------------------------- Has ID(s)  # ------------------------------------------------------------------- Has ID(s)
Line 4299  sub symbclean { Line 4422  sub symbclean {
 # remove version from URL  # remove version from URL
     $symb=~s/\.(\d+)\.(\w+)$/\.$2/;      $symb=~s/\.(\d+)\.(\w+)$/\.$2/;
   
   # remove wrapper
   
       $symb=~s/(\_\_\_\d+\_\_\_)adm\/wrapper\/(res\/)*/$1/;
     return $symb;      return $symb;
 }  }
   
Line 4462  sub numval2 { Line 4588  sub numval2 {
 }  }
   
 sub latest_rnd_algorithm_id {  sub latest_rnd_algorithm_id {
     return '64bit2';      return '64bit3';
   }
   
   sub get_rand_alg {
       my ($courseid)=@_;
       if (!$courseid) { $courseid=(&Apache::lonxml::whichuser())[1]; }
       if ($courseid) {
    return $ENV{"course.$courseid.rndseed"};
       }
       return &latest_rnd_algorithm_id();
 }  }
   
 sub getCODE {  sub getCODE {
Line 4484  sub rndseed { Line 4619  sub rndseed {
     if (!$courseid) { $courseid=$wcourseid; }      if (!$courseid) { $courseid=$wcourseid; }
     if (!$domain) { $domain=$wdomain; }      if (!$domain) { $domain=$wdomain; }
     if (!$username) { $username=$wusername }      if (!$username) { $username=$wusername }
     my $which=$ENV{"course.$courseid.rndseed"};      my $which=&get_rand_alg();
     if (defined(&getCODE())) {      if (defined(&getCODE())) {
  return &rndseed_CODE_64bit($symb,$courseid,$domain,$username);   return &rndseed_CODE_64bit($symb,$courseid,$domain,$username);
       } elsif ($which eq '64bit3') {
    return &rndseed_64bit3($symb,$courseid,$domain,$username);
     } elsif ($which eq '64bit2') {      } elsif ($which eq '64bit2') {
  return &rndseed_64bit2($symb,$courseid,$domain,$username);   return &rndseed_64bit2($symb,$courseid,$domain,$username);
     } elsif ($which eq '64bit') {      } elsif ($which eq '64bit') {
Line 4554  sub rndseed_64bit2 { Line 4691  sub rndseed_64bit2 {
     }      }
 }  }
   
   sub rndseed_64bit3 {
       my ($symb,$courseid,$domain,$username)=@_;
       {
    use integer;
    # strings need to be an even # of cahracters long, it it is odd the
           # last characters gets thrown away
    my $symbchck=unpack("%32S*",$symb.' ') << 21;
    my $symbseed=numval2($symb) << 10;
    my $namechck=unpack("%32S*",$username.' ');
   
    my $nameseed=numval2($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 {  sub rndseed_CODE_64bit {
     my ($symb,$courseid,$domain,$username)=@_;      my ($symb,$courseid,$domain,$username)=@_;
     {      {
Line 4567  sub rndseed_CODE_64bit { Line 4726  sub rndseed_CODE_64bit {
  my $num2=$CODEseed+$courseseed+$symbchck;   my $num2=$CODEseed+$courseseed+$symbchck;
  #&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");   #&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");
  #&Apache::lonxml::debug("rndseed :$num1:$num2:$symb");   #&Apache::lonxml::debug("rndseed :$num1:$num2:$symb");
  return "$num1,$num2";   return "$num1:$num2";
     }      }
 }  }
   
 sub setup_random_from_rndseed {  sub setup_random_from_rndseed {
     my ($rndseed)=@_;      my ($rndseed)=@_;
     if ($rndseed =~/,/) {      if ($rndseed =~/([,:])/) {
  my ($num1,$num2)=split(/,/,$rndseed);   my ($num1,$num2)=split(/[,:]/,$rndseed);
  &Math::Random::random_set_seed(abs($num1),abs($num2));   &Math::Random::random_set_seed(abs($num1),abs($num2));
     } else {      } else {
  &Math::Random::random_set_seed_from_phrase($rndseed);   &Math::Random::random_set_seed_from_phrase($rndseed);
Line 4821  sub declutter { Line 4980  sub declutter {
   
 sub clutter {  sub clutter {
     my $thisfn='/'.&declutter(shift);      my $thisfn='/'.&declutter(shift);
     unless ($thisfn=~/^\/(uploaded|adm|userfiles|ext|raw|priv)\//) {       unless ($thisfn=~/^\/(uploaded|adm|userfiles|ext|raw|priv|public)\//) { 
        $thisfn='/res'.$thisfn;          $thisfn='/res'.$thisfn; 
     }      }
     return $thisfn;      return $thisfn;
Removed from v.1.495  
changed lines
  Added in v.1.511

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