[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.513 and 1.524

version 1.513, 2004/06/21 22:01:39 version 1.524, 2004/07/22 23:08:44
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 1282  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='';
Line 1395  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 1472  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 1596  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 1627  sub courseiddump { Line 1647  sub courseiddump {
                                $tryserver))) {                                 $tryserver))) {
     my ($key,$value)=split(/\=/,$_);      my ($key,$value)=split(/\=/,$_);
                     if (($key) && ($value)) {                      if (($key) && ($value)) {
         $returnhash{&unescape($key)}=&unescape($value);          $returnhash{&unescape($key)}=$value;
                     }                      }
                 }                  }
             }              }
Line 2571  sub put { Line 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 3076  sub fetch_enrollment_query { Line 3120  sub fetch_enrollment_query {
     unless ($queryid=~/^\Q$host\E\_/) { return 'error: '.$queryid; }      unless ($queryid=~/^\Q$host\E\_/) { return 'error: '.$queryid; }
     my $reply = &get_query_reply($queryid);      my $reply = &get_query_reply($queryid);
     unless ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {      unless ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
         unless ($homeserver eq $perlvar{'lonHostID'}) {          my @responses = split/:/,$reply;
             my @responses = split/:/,$reply;          if ($homeserver eq $perlvar{'lonHostID'}) {
               foreach (@responses) {
                   my ($key,$value) = split/=/,$_;
                   $$replyref{$key} = $value;
               }
           } else {
             my $pathname = $perlvar{'lonDaemons'}.'/tmp';              my $pathname = $perlvar{'lonDaemons'}.'/tmp';
             foreach (@responses) {              foreach (@responses) {
                 my ($key,$value) = split/=/,$_;                  my ($key,$value) = split/=/,$_;
Line 3169  sub auto_get_sections { Line 3218  sub auto_get_sections {
 sub auto_new_course {  sub auto_new_course {
     my ($cnum,$cdom,$inst_course_id,$owner) = @_;      my ($cnum,$cdom,$inst_course_id,$owner) = @_;
     my $homeserver = &homeserver($cnum,$cdom);      my $homeserver = &homeserver($cnum,$cdom);
     my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner,':'.$cdom,$homeserver));      my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner.':'.$cdom,$homeserver));
     return $response;      return $response;
 }  }
                                                                                                                                                                         
Line 3194  sub auto_create_password { Line 3243  sub auto_create_password {
     return ($authparam,$create_passwd,$authchk);      return ($authparam,$create_passwd,$authchk);
 }  }
   
   sub auto_instcode_format {
       my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,$cat_order) = @_;
       my $courses = '';
       my $homeserver;
       if ($caller eq 'global') {
           $homeserver = $perlvar{'lonHostID'};
       } else {
           $homeserver = &homeserver($caller,$codedom);
       }
       my $host=$hostname{$homeserver};
       foreach (keys %{$instcodes}) {
           $courses .= &escape($_).'='.&escape($$instcodes{$_}).'&';
       }
       chop($courses);
       my $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$homeserver);
       unless ($response =~ /(con_lost|error|no_such_host|refused)/) {
           my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = split/:/,$response;
           %{$codes} = &str2hash($codes_str);
           @{$codetitles} = &str2array($codetitles_str);
           %{$cat_titles} = &str2hash($cat_titles_str);
           %{$cat_order} = &str2hash($cat_order_str);
           return 'ok';
       }
       return $response;
   }
   
 # ------------------------------------------------------------------ Plain Text  # ------------------------------------------------------------------ Plain Text
   
 sub plaintext {  sub plaintext {
Line 3384  sub modifyuser { Line 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 3399  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 3451  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 3487  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 3520  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 3577  sub revokecustomrole { Line 3651  sub revokecustomrole {
   
   
 # ------------------------------------------------------------ Portfolio Director Lister  # ------------------------------------------------------------ Portfolio Director Lister
   # returns listing of contents of user's /userfiles/portfolio/ directory
   # 
   
 sub portfoliolist {  sub portfoliolist {
  # returns listing of contents of user's /userfiles/portfolio/ directory      my ($currentPath, $currentFile) = @_;
  #       my ($udom, $uname, $portfolioRoot);
  my ($udom, $uname, $uhome);      $uname=$ENV{'user.name'};
  $uname=$ENV{'user.name'};      $udom=$ENV{'user.domain'};
         $udom=$ENV{'user.domain'};      # really should interrogate the system for home directory information, but . . .
         $uhome=$ENV{'user.home'};      $portfolioRoot = '/home/httpd/lonUsers/'.$udom.'/';
  my $listing = reply('portls:'.$uname.':'.$udom, $uhome);      $uname =~ /^(.?)(.?)(.?)/;
  return $listing;      $portfolioRoot = $portfolioRoot.$1.'/'.$2.'/'.$3.'/'.$uname.'/userfiles/portfolio';
       my $listing = &reply('ls:'.$portfolioRoot.$currentPath, &homeserver($uname,$udom));
       return $listing;
 }  }
   
 sub portfoliomanage {  sub portfoliomanage {
  # handles deleting and renaming files in user's userfiles/portfolio/ directory  
  #   #FIXME please user the existing remove userfile function instead and
  my ($filename, $fileaction, $filenewname) = @_;  #add a userfilerename functions.
  my ($udom, $uname, $uhome);  #FIXME uhome should never be an argument to any lonnet functions
  $uname=$ENV{'user.name'};  
         $udom=$ENV{'user.domain'};      # handles deleting and renaming files in user's userfiles/portfolio/ directory
         $uhome=$ENV{'user.home'};      # 
  my $listing = reply('portfoliomanage:'.$uname.':'.$udom.':'.$filename.':'.$fileaction.':'.$filenewname, $uhome);      my ($filename, $fileaction, $filenewname) = @_;
  return $listing;      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;
 }  }
   
   
Line 4863  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 4876  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 4898  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 5826  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.513  
changed lines
  Added in v.1.524

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