[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.492 and 1.525

version 1.492, 2004/04/29 17:25:11 version 1.525, 2004/08/05 16:59:29
Line 38  use vars Line 38  use vars
 qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom   qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom 
    %libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache     %libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache
    %courselogs %accesshash %userrolehash $processmarker $dumpcount      %courselogs %accesshash %userrolehash $processmarker $dumpcount 
    %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache      %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseresdatacache 
    %userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def      %userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def 
    %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir);     %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir);
   
Line 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 1127  sub ssi_body { Line 1131  sub ssi_body {
     my ($filelink,%form)=@_;      my ($filelink,%form)=@_;
     my $output=($filelink=~/^http\:/?&externalssi($filelink):      my $output=($filelink=~/^http\:/?&externalssi($filelink):
                                      &ssi($filelink,%form));                                       &ssi($filelink,%form));
     $output=~s/^.*?\<body[^\>]*\>//si;  
     $output=~s/(.*)\<\/body\s*\>.*?$/$1/si;  
     $output=~      $output=~
             s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs;              s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs;
       $output=~s/^.*?\<body[^\>]*\>//si;
       $output=~s/(.*)\<\/body\s*\>.*?$/$1/si;
     return $output;      return $output;
 }  }
   
Line 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 1268  sub process_coursefile { Line 1268  sub process_coursefile {
 # output: url of file in userspace  # output: url of file in userspace
   
 sub userfileupload {  sub userfileupload {
     my ($formname,$coursedoc)=@_;      my ($formname,$coursedoc,$subdir)=@_;
       if (!defined($subdir)) { $subdir='unknown'; }
     my $fname=$ENV{'form.'.$formname.'.filename'};      my $fname=$ENV{'form.'.$formname.'.filename'};
 # Replace Windows backslashes by forward slashes  # Replace Windows backslashes by forward slashes
     $fname=~s/\\/\//g;      $fname=~s/\\/\//g;
Line 1281  sub userfileupload { Line 1282  sub userfileupload {
 # See if there is anything left  # See if there is anything left
     unless ($fname) { return 'error: no uploaded file'; }      unless ($fname) { return 'error: no uploaded file'; }
     chop($ENV{'form.'.$formname});      chop($ENV{'form.'.$formname});
       if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) { #files uploaded to help request form are handled differently
           my $now = time;
           my $filepath = 'tmp/helprequests/'.$now;
           my @parts=split(/\//,$filepath);
           my $fullpath = $perlvar{'lonDaemons'};
           for (my $i=0;$i<@parts;$i++) {
               $fullpath .= '/'.$parts[$i];
               if ((-e $fullpath)!=1) {
                   mkdir($fullpath,0777);
               }
           }
           open(my $fh,'>'.$fullpath.'/'.$fname);
           print $fh $ENV{'form.'.$formname};
           close($fh);
           return $fullpath.'/'.$fname; 
       }
 # Create the directory if not present  # Create the directory if not present
     my $docuname='';      my $docuname='';
     my $docudom='';      my $docudom='';
     my $docuhome='';      my $docuhome='';
       $fname="$subdir/$fname";
     if ($coursedoc) {      if ($coursedoc) {
  $docuname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'};   $docuname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'};
  $docudom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'};   $docudom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'};
Line 1307  sub finishuserfileupload { Line 1325  sub finishuserfileupload {
     my ($docuname,$docudom,$docuhome,$formname,$fname)=@_;      my ($docuname,$docudom,$docuhome,$formname,$fname)=@_;
     my $path=$docudom.'/'.$docuname.'/';      my $path=$docudom.'/'.$docuname.'/';
     my $filepath=$perlvar{'lonDocRoot'};      my $filepath=$perlvar{'lonDocRoot'};
       my ($fnamepath,$file);
       $file=$fname;
       if ($fname=~m|/|) {
           ($fnamepath,$file) = ($fname =~ m|^(.*)/([^/]+)$|);
    $path.=$fnamepath.'/';
       }
     my @parts=split(/\//,$filepath.'/userfiles/'.$path);      my @parts=split(/\//,$filepath.'/userfiles/'.$path);
     my $count;      my $count;
     for ($count=4;$count<=$#parts;$count++) {      for ($count=4;$count<=$#parts;$count++) {
Line 1317  sub finishuserfileupload { Line 1341  sub finishuserfileupload {
     }      }
 # Save the file  # Save the file
     {      {
        open(my $fh,'>'.$filepath.'/'.$fname);   #&Apache::lonnet::logthis("Saving to $filepath $file");
          open(my $fh,'>'.$filepath.'/'.$file);
        print $fh $ENV{'form.'.$formname};         print $fh $ENV{'form.'.$formname};
        close($fh);         close($fh);
     }      }
 # Notify homeserver to grep it  # Notify homeserver to grep it
 #  #
     my $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,      my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);
     $docuhome);  
     if ($fetchresult eq 'ok') {      if ($fetchresult eq 'ok') {
 #  #
 # Return the URL to it  # Return the URL to it
         return '/uploaded/'.$path.$fname;          return '/uploaded/'.$path.$file;
     } else {      } else {
         &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$fname.          &logthis('Failed to transfer '.$path.$file.' to host '.$docuhome.
          ' to host '.$docuhome.': '.$fetchresult);   ': '.$fetchresult);
         return '/adm/notfound.html';          return '/adm/notfound.html';
     }          }    
 }  }
   
   sub removeuploadedurl {
       my ($url)=@_;
       my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);
       return &Apache::lonnet::removeuserfile($uname,$udom,$fname);
   }
   
 sub removeuserfile {  sub removeuserfile {
     my ($docuname,$docudom,$fname)=@_;      my ($docuname,$docudom,$fname)=@_;
     my $home=&homeserver($docuname,$docudom);      my $home=&homeserver($docuname,$docudom);
Line 1381  sub flushcourselogs { Line 1411  sub flushcourselogs {
         }          }
         if ($courseidbuffer{$coursehombuf{$crsid}}) {          if ($courseidbuffer{$coursehombuf{$crsid}}) {
            $courseidbuffer{$coursehombuf{$crsid}}.='&'.             $courseidbuffer{$coursehombuf{$crsid}}.='&'.
  &escape($crsid).'='.&escape($coursedescrbuf{$crsid});   &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
                            '='.&escape($courseinstcodebuf{$crsid});
         } else {          } else {
            $courseidbuffer{$coursehombuf{$crsid}}=             $courseidbuffer{$coursehombuf{$crsid}}=
  &escape($crsid).'='.&escape($coursedescrbuf{$crsid});   &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
                            '='.&escape($courseinstcodebuf{$crsid});
         }              }    
     }      }
 #  #
Line 1458  sub courselog { Line 1490  sub courselog {
        $ENV{'course.'.$ENV{'request.course.id'}.'.home'};         $ENV{'course.'.$ENV{'request.course.id'}.'.home'};
     $coursedescrbuf{$ENV{'request.course.id'}}=      $coursedescrbuf{$ENV{'request.course.id'}}=
        $ENV{'course.'.$ENV{'request.course.id'}.'.description'};         $ENV{'course.'.$ENV{'request.course.id'}.'.description'};
       $courseinstcodebuf{$ENV{'request.course.id'}}=
          $ENV{'course.'.$ENV{'request.course.id'}.'.internal.coursecode'};
     if (defined $courselogs{$ENV{'request.course.id'}}) {      if (defined $courselogs{$ENV{'request.course.id'}}) {
  $courselogs{$ENV{'request.course.id'}}.='&'.$what;   $courselogs{$ENV{'request.course.id'}}.='&'.$what;
     } else {      } else {
Line 1582  sub getannounce { Line 1616  sub getannounce {
  if ($announcement=~/\w/) {    if ($announcement=~/\w/) { 
     return       return 
    '<table bgcolor="#FF5555" cellpadding="5" cellspacing="3">'.     '<table bgcolor="#FF5555" cellpadding="5" cellspacing="3">'.
    '<tr><td bgcolor="#FFFFFF"><pre>'.$announcement.'</pre></td></tr></table>';      '<tr><td bgcolor="#FFFFFF"><tt>'.$announcement.'</tt></td></tr></table>'; 
  } else {   } else {
     return '';      return '';
  }   }
Line 1601  sub courseidput { Line 1635  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)}=$value;
                       }
                 }                  }
             }              }
   
         }          }
     }      }
     return %returnhash;      return %returnhash;
Line 1624  sub courseiddump { Line 1659  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 1802  sub hash2str { Line 1859  sub hash2str {
 sub hashref2str {  sub hashref2str {
   my ($hashref)=@_;    my ($hashref)=@_;
   my $result='__HASH_REF__';    my $result='__HASH_REF__';
   foreach (keys(%$hashref)) {    foreach (sort(keys(%$hashref))) {
     if (ref($_) eq 'ARRAY') {      if (ref($_) eq 'ARRAY') {
       $result.=&arrayref2str($_).'=';        $result.=&arrayref2str($_).'=';
     } elsif (ref($_) eq 'HASH') {      } elsif (ref($_) eq 'HASH') {
Line 2534  sub put { Line 2591  sub put {
    return &reply("put:$udomain:$uname:$namespace:$items",$uhome);     return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
 }  }
   
   # ---------------------------------------------------------- putstore interface
                                                                                        
   sub putstore {
      my ($namespace,$storehash,$udomain,$uname)=@_;
      if (!$udomain) { $udomain=$ENV{'user.domain'}; }
      if (!$uname) { $uname=$ENV{'user.name'}; }
      my $uhome=&homeserver($uname,$udomain);
      my $items='';
      my %allitems = ();
      foreach (keys %$storehash) {
          if ($_ =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) {
              my $key = $1.':keys:'.$2;
              $allitems{$key} .= $3.':';
          }
          $items.=$_.'='.&escape($$storehash{$_}).'&';
      }
      foreach (keys %allitems) {
          $allitems{$_} =~ s/\:$//;
          $items.= $_.'='.$allitems{$_}.'&';
      }
      $items=~s/\&$//;
      return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
   }
   
 # ------------------------------------------------------ critical put interface  # ------------------------------------------------------ critical put interface
   
 sub cput {  sub cput {
Line 3017  sub log_query { Line 3098  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/) ) {
           my @responses = split/:/,$reply;
           if ($homeserver eq $perlvar{'lonHostID'}) {
               foreach (@responses) {
                   my ($key,$value) = split/=/,$_;
                   $$replyref{$key} = $value;
               }
           } else {
               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 3061  sub userlog_query { Line 3195  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);
   }
   
   sub auto_instcode_format {
       my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,$cat_order) = @_;
       my $courses = '';
       my $homeserver;
       if ($caller eq 'global') {
           $homeserver = $perlvar{'lonHostID'};
       } else {
           $homeserver = &homeserver($caller,$codedom);
       }
       my $host=$hostname{$homeserver};
       foreach (keys %{$instcodes}) {
           $courses .= &escape($_).'='.&escape($$instcodes{$_}).'&';
       }
       chop($courses);
       my $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$homeserver);
       unless ($response =~ /(con_lost|error|no_such_host|refused)/) {
           my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = split/:/,$response;
           %{$codes} = &str2hash($codes_str);
           @{$codetitles} = &str2array($codetitles_str);
           %{$cat_titles} = &str2hash($cat_titles_str);
           %{$cat_order} = &str2hash($cat_order_str);
           return 'ok';
       }
       return $response;
   }
   
 # ------------------------------------------------------------------ Plain Text  # ------------------------------------------------------------------ Plain Text
   
 sub plaintext {  sub plaintext {
Line 3251  sub modifyuser { Line 3459  sub modifyuser {
   
 sub modifystudent {  sub modifystudent {
     my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,      my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
         $end,$start,$forceid,$desiredhome,$email,$type,$cid)=@_;          $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid)=@_;
     if (!$cid) {      if (!$cid) {
  unless ($cid=$ENV{'request.course.id'}) {   unless ($cid=$ENV{'request.course.id'}) {
     return 'not_in_class';      return 'not_in_class';
Line 3266  sub modifystudent { Line 3474  sub modifystudent {
     # students environment      # students environment
     $uid = undef if (!$forceid);      $uid = undef if (!$forceid);
     $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,      $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
  $gene,$usec,$end,$start,$type,$cid);   $gene,$usec,$end,$start,$type,$locktype,$cid);
     return $reply;      return $reply;
 }  }
   
 sub modify_student_enrollment {  sub modify_student_enrollment {
     my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,      my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid) = @_;
  $cid) = @_;  
     my ($cdom,$cnum,$chome);      my ($cdom,$cnum,$chome);
     if (!$cid) {      if (!$cid) {
  unless ($cid=$ENV{'request.course.id'}) {   unless ($cid=$ENV{'request.course.id'}) {
Line 3318  sub modify_student_enrollment { Line 3525  sub modify_student_enrollment {
                                                            $first,$middle);                                                             $first,$middle);
     my $reply=cput('classlist',      my $reply=cput('classlist',
    {"$uname:$udom" =>      {"$uname:$udom" => 
  join(':',$end,$start,$uid,$usec,$fullname,$type) },   join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) },
    $cdom,$cnum);     $cdom,$cnum);
     unless (($reply eq 'ok') || ($reply eq 'delayed')) {      unless (($reply eq 'ok') || ($reply eq 'delayed')) {
  return 'error: '.$reply;   return 'error: '.$reply;
Line 3354  sub writecoursepref { Line 3561  sub writecoursepref {
 # ---------------------------------------------------------- Make/modify course  # ---------------------------------------------------------- Make/modify course
   
 sub createcourse {  sub createcourse {
     my ($udom,$description,$url,$course_server,$nonstandard)=@_;      my ($udom,$description,$url,$course_server,$nonstandard,$inst_code)=@_;
     $url=&declutter($url);      $url=&declutter($url);
     my $cid='';      my $cid='';
     unless (&allowed('ccc',$udom)) {      unless (&allowed('ccc',$udom)) {
Line 3387  sub createcourse { Line 3594  sub createcourse {
  return 'error: no such course';   return 'error: no such course';
     }      }
 # ----------------------------------------------------------------- Course made  # ----------------------------------------------------------------- Course made
 # log existance  # log existence
     &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description),      &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description).
                  $uhome);                   '='.&escape($inst_code),$uhome);
     &flushcourselogs();      &flushcourselogs();
 # set toplevel url  # set toplevel url
     my $topurl=$url;      my $topurl=$url;
Line 3442  sub revokecustomrole { Line 3649  sub revokecustomrole {
            $deleteflag);             $deleteflag);
 }  }
   
   
   # ------------------------------------------------------------ Portfolio Director Lister
   # returns listing of contents of user's /userfiles/portfolio/ directory
   # 
   
   sub portfoliolist {
       my ($currentPath, $currentFile) = @_;
       my ($udom, $uname, $portfolioRoot);
       $uname=$ENV{'user.name'};
       $udom=$ENV{'user.domain'};
       # really should interrogate the system for home directory information, but . . .
       $portfolioRoot = '/home/httpd/lonUsers/'.$udom.'/';
       $uname =~ /^(.?)(.?)(.?)/;
       $portfolioRoot = $portfolioRoot.$1.'/'.$2.'/'.$3.'/'.$uname.'/userfiles/portfolio';
       my $listing = &reply('ls:'.$portfolioRoot.$currentPath, &homeserver($uname,$udom));
       return $listing;
   }
   
   sub portfoliomanage {
   
   #FIXME please user the existing remove userfile function instead and
   #add a userfilerename functions.
   #FIXME uhome should never be an argument to any lonnet functions
   
       # handles deleting and renaming files in user's userfiles/portfolio/ directory
       # 
       my ($filename, $fileaction, $filenewname) = @_;
       my ($udom, $uname, $uhome);
       $uname=$ENV{'user.name'};
       $udom=$ENV{'user.domain'};
       $uhome=$ENV{'user.home'};
       my $listing = reply('portfoliomanage:'.$uname.':'.$udom.':'.$filename.':'.$fileaction.':'.$filenewname, $uhome);
       return $listing;
   }
   
   
 # ------------------------------------------------------------ Directory lister  # ------------------------------------------------------------ Directory lister
   
 sub dirlist {  sub dirlist {
Line 4237  sub symblist { Line 4480  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 4247  sub symbverify { Line 4493  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 4254  sub symbverify { Line 4501  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 4285  sub symbclean { Line 4532  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 4448  sub numval2 { Line 4698  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 4470  sub rndseed { Line 4729  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 4540  sub rndseed_64bit2 { Line 4801  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 4553  sub rndseed_CODE_64bit { Line 4836  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 4665  sub getfile { Line 4948  sub getfile {
     if ($rtncode eq '404') {      if ($rtncode eq '404') {
  unlink($localfile);   unlink($localfile);
     }      }
       #my $ua=new LWP::UserAgent;
       #my $request=new HTTP::Request('GET',&tokenwrapper($file));
       #my $response=$ua->request($request);
       #if ($response->is_success()) {
    # return $response->content;
    #    } else {
    # return -1;
    #    }
     return -1;      return -1;
  }   }
  if ($info < $fileinfo[9]) {   if ($info < $fileinfo[9]) {
Line 4678  sub getfile { Line 4969  sub getfile {
     } else {      } else {
  $lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode);   $lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode);
  if ($lwpresp ne 'ok') {   if ($lwpresp ne 'ok') {
     return -1;      my $ua=new LWP::UserAgent;
       my $request=new HTTP::Request('GET',&tokenwrapper($file));
       my $response=$ua->request($request);
       if ($response->is_success()) {
    return $response->content;
       } else {
    return -1;
       }
  }   }
  my @parts = ($cdom,$cnum);    my @parts = ($cdom,$cnum); 
  if ($filename =~ m|^(.+)/[^/]+$|) {   if ($filename =~ m|^(.+)/[^/]+$|) {
     push @parts, split(/\//,$1);      push @parts, split(/\//,$1);
     }   }
  foreach my $part (@parts) {   foreach my $part (@parts) {
     $path .= '/'.$part;      $path .= '/'.$part;
     if (!-e $path) {      if (!-e $path) {
Line 4700  sub getfile { Line 4998  sub getfile {
     return $info;      return $info;
 }  }
   
   sub tokenwrapper {
       my $uri=shift;
       $uri=~s/^http\:\/\/([^\/]+)//;
       $uri=~s/^\///;
       $ENV{'user.environment'}=~/\/([^\/]+)\.id/;
       my $token=$1;
       if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) {
           &appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'});
           return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri.
                  (($uri=~/\?/)?'&':'?').'token='.$token.
                                  '&tokenissued='.$perlvar{'lonHostID'};
       } else {
           return '/adm/notfound.html';
       }
   }
   
 sub getuploaded {  sub getuploaded {
     my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;      my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
     $uri=~s/^\///;      $uri=~s/^\///;
Line 4807  sub declutter { Line 5121  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;
Line 5628  put($namespace,$storehash,$udom,$uname) Line 5942  put($namespace,$storehash,$udom,$uname)
   
 =item *  =item *
   
   putstore($namespace,$storehash,$udomain,$uname) : stores hash in namesp
   keys used in storehash include version information (e.g., 1:$symb:message etc.) as
   used in records written by &store and retrieved by &restore.  This function 
   was created for use in editing discussion posts, without incrementing the
   version number included in the key for a particular post. The colon 
   separated list of attribute names (e.g., the value associated with the key 
   1:keys:$symb) is also generated and passed in the ampersand separated 
   items sent to lonnet::reply().  
   
   =item *
   
 cput($namespace,$storehash,$udom,$uname) : critical put  cput($namespace,$storehash,$udom,$uname) : critical put
 ($udom and $uname are optional)  ($udom and $uname are optional)
   
Removed from v.1.492  
changed lines
  Added in v.1.525

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