[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.716 and 1.726

version 1.716, 2006/03/04 04:25:31 version 1.726, 2006/04/06 19:14:50
Line 260  sub critical { Line 260  sub critical {
   
 sub transfer_profile_to_env {  sub transfer_profile_to_env {
     my ($lonidsdir,$handle)=@_;      my ($lonidsdir,$handle)=@_;
       if (!defined($lonidsdir)) {
    $lonidsdir = $perlvar{'lonIDsDir'};
       }
       if (!defined($handle)) {
           ($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| );
       }
   
     my @profile;      my @profile;
     {      {
  open(my $idf,"$lonidsdir/$handle.id");   open(my $idf,"$lonidsdir/$handle.id");
Line 272  sub transfer_profile_to_env { Line 279  sub transfer_profile_to_env {
     for ($envi=0;$envi<=$#profile;$envi++) {      for ($envi=0;$envi<=$#profile;$envi++) {
  chomp($profile[$envi]);   chomp($profile[$envi]);
  my ($envname,$envvalue)=split(/=/,$profile[$envi],2);   my ($envname,$envvalue)=split(/=/,$profile[$envi],2);
    $envname=&unescape($envname);
    $envvalue=&unescape($envvalue);
  $env{$envname} = $envvalue;   $env{$envname} = $envvalue;
         if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {          if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {
             if ($time < time-300) {              if ($time < time-300) {
Line 324  sub appenv { Line 333  sub appenv {
         chomp($oldenv[$i]);          chomp($oldenv[$i]);
         if ($oldenv[$i] ne '') {          if ($oldenv[$i] ne '') {
     my ($name,$value)=split(/=/,$oldenv[$i],2);      my ($name,$value)=split(/=/,$oldenv[$i],2);
       $name=&unescape($name);
       $value=&unescape($value);
     unless (defined($newenv{$name})) {      unless (defined($newenv{$name})) {
  $newenv{$name}=$value;   $newenv{$name}=$value;
     }      }
Line 336  sub appenv { Line 347  sub appenv {
  }   }
  my $newname;   my $newname;
  foreach $newname (keys %newenv) {   foreach $newname (keys %newenv) {
     print $fh "$newname=$newenv{$newname}\n";      print $fh &escape($newname).'='.&escape($newenv{$newname})."\n";
  }   }
  close($fh);   close($fh);
     }      }
Line 348  sub appenv { Line 359  sub appenv {
   
 sub delenv {  sub delenv {
     my $delthis=shift;      my $delthis=shift;
     my %newenv=();  
     if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {      if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {
         &logthis("<font color=\"blue\">WARNING: ".          &logthis("<font color=\"blue\">WARNING: ".
                 "Attempt to delete from environment ".$delthis);                  "Attempt to delete from environment ".$delthis);
Line 381  sub delenv { Line 391  sub delenv {
     return 'error: '.$!;      return 'error: '.$!;
  }   }
  foreach my $cur_key (@oldenv) {   foreach my $cur_key (@oldenv) {
     if ($cur_key=~/^$delthis/) {       my $unescaped_cur_key = &unescape($cur_key);
                 my ($key,undef) = split('=',$cur_key,2);      if ($unescaped_cur_key=~/^$delthis/) { 
                   my ($key) = split('=',$cur_key,2);
    $key = &unescape($key);
                 delete($env{$key});                  delete($env{$key});
             } else {              } else {
                 print $fh $cur_key;                   print $fh $cur_key; 
Line 843  sub save_cache { Line 855  sub save_cache {
     my ($r)=@_;      my ($r)=@_;
     if (! $r->is_initial_req()) { return DECLINED; }      if (! $r->is_initial_req()) { return DECLINED; }
     &purge_remembered();      &purge_remembered();
       #&Apache::loncommon::validate_page();
     undef(%env);      undef(%env);
     return OK;      return OK;
 }  }
Line 996  sub retrievestudentphoto { Line 1009  sub retrievestudentphoto {
 # -------------------------------------------------------------------- New chat  # -------------------------------------------------------------------- New chat
   
 sub chatsend {  sub chatsend {
     my ($newentry,$anon)=@_;      my ($newentry,$anon,$group)=@_;
     my $cnum=$env{'course.'.$env{'request.course.id'}.'.num'};      my $cnum=$env{'course.'.$env{'request.course.id'}.'.num'};
     my $cdom=$env{'course.'.$env{'request.course.id'}.'.domain'};      my $cdom=$env{'course.'.$env{'request.course.id'}.'.domain'};
     my $chome=$env{'course.'.$env{'request.course.id'}.'.home'};      my $chome=$env{'course.'.$env{'request.course.id'}.'.home'};
     &reply('chatsend:'.$cdom.':'.$cnum.':'.      &reply('chatsend:'.$cdom.':'.$cnum.':'.
    &escape($env{'user.domain'}.':'.$env{'user.name'}.':'.$anon.':'.     &escape($env{'user.domain'}.':'.$env{'user.name'}.':'.$anon.':'.
    &escape($newentry)),$chome);     &escape($newentry)).':'.$group,$chome);
 }  }
   
 # ------------------------------------------ Find current version of a resource  # ------------------------------------------ Find current version of a resource
Line 1320  sub clean_filename { Line 1333  sub clean_filename {
   
 # --------------- Take an uploaded file and put it into the userfiles directory  # --------------- Take an uploaded file and put it into the userfiles directory
 # input: $formname - the contents of the file are in $env{"form.$formname"}  # input: $formname - the contents of the file are in $env{"form.$formname"}
 #                    the desired filenam is in $env{"form.$formname"}  #                    the desired filenam is in $env{"form.$formname.filename"}
 #        $coursedoc - if true up to the current course  #        $coursedoc - if true up to the current course
 #                     if false  #                     if false
 #        $subdir - directory in userfile to store the file into  #        $subdir - directory in userfile to store the file into
Line 1331  sub clean_filename { Line 1344  sub clean_filename {
   
   
 sub userfileupload {  sub userfileupload {
     my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase)=@_;      my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname,$destudom)=@_;
     if (!defined($subdir)) { $subdir='unknown'; }      if (!defined($subdir)) { $subdir='unknown'; }
     my $fname=$env{'form.'.$formname.'.filename'};      my $fname=$env{'form.'.$formname.'.filename'};
     $fname=&clean_filename($fname);      $fname=&clean_filename($fname);
Line 1354  sub userfileupload { Line 1367  sub userfileupload {
         close($fh);          close($fh);
         return $fullpath.'/'.$fname;           return $fullpath.'/'.$fname; 
     }      }
       
 # Create the directory if not present  # Create the directory if not present
     $fname="$subdir/$fname";      $fname="$subdir/$fname";
     if ($coursedoc) {      if ($coursedoc) {
Line 1369  sub userfileupload { Line 1383  sub userfileupload {
        $fname,$formname,$parser,         $fname,$formname,$parser,
        $allfiles,$codebase);         $allfiles,$codebase);
         }          }
       } elsif (defined($destuname)) {
           my $docuname=$destuname;
           my $docudom=$destudom;
    return &finishuserfileupload($docuname,$docudom,$formname,
        $fname,$parser,$allfiles,$codebase);
           
     } else {      } else {
         my $docuname=$env{'user.name'};          my $docuname=$env{'user.name'};
         my $docudom=$env{'user.domain'};          my $docudom=$env{'user.domain'};
Line 2855  sub dump { Line 2875  sub dump {
    return %returnhash;     return %returnhash;
 }  }
   
   # --------------------------------------------------------- dumpstore interface
   
   sub dumpstore {
      my ($namespace,$udomain,$uname,$regexp,$range)=@_;
      return &dump($namespace,$udomain,$uname,$regexp,$range);
   }
   
 # -------------------------------------------------------------- keys interface  # -------------------------------------------------------------- keys interface
   
 sub getkeys {  sub getkeys {
Line 4719  sub GetFileTimestamp { Line 4746  sub GetFileTimestamp {
 sub stat_file {  sub stat_file {
     my ($uri) = @_;      my ($uri) = @_;
     $uri = &clutter($uri);      $uri = &clutter($uri);
   
       # we want just the url part without the unneeded accessor url bits
       if ($uri =~ m-^/adm/-) {
    $uri=~s-^/adm/wrapper/-/-;
    $uri=~s-^/adm/coursedocs/showdoc/-/-;
       }
     my ($udom,$uname,$file,$dir);      my ($udom,$uname,$file,$dir);
     if ($uri =~ m-^/(uploaded|editupload)/-) {      if ($uri =~ m-^/(uploaded|editupload)/-) {
  ($udom,$uname,$file) =   ($udom,$uname,$file) =
Line 4739  sub stat_file { Line 4772  sub stat_file {
   
     my ($result) = &dirlist($file,$udom,$uname,$dir);      my ($result) = &dirlist($file,$udom,$uname,$dir);
     my @stats = split('&', $result);      my @stats = split('&', $result);
       
     if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {      if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
  shift(@stats); #filename is first   shift(@stats); #filename is first
  return @stats;   return @stats;
Line 5085  sub EXT { Line 5119  sub EXT {
  ($env{'user.domain'} eq $udom)) {   ($env{'user.domain'} eq $udom)) {
  $section=$env{'request.course.sec'};   $section=$env{'request.course.sec'};
                 @groups=&sort_course_groups($env{'request.course.groups'},$courseid);                   @groups=&sort_course_groups($env{'request.course.groups'},$courseid); 
                 if (@groups > 0) {  
                     @groups = sort(@groups);  
                 }  
     } else {      } else {
  if (! defined($usection)) {   if (! defined($usection)) {
     $section=&getsection($udom,$uname,$courseid);      $section=&getsection($udom,$uname,$courseid);
Line 5222  sub check_group_parms { Line 5253  sub check_group_parms {
   
 sub sort_course_groups { # Sort groups based on defined rankings. Default is sort().  sub sort_course_groups { # Sort groups based on defined rankings. Default is sort().
     my ($grouplist,$courseid) = @_;      my ($grouplist,$courseid) = @_;
     my @groups = split/:/,$grouplist;      my @groups = sort(split(/:/,$grouplist));
     if (@groups > 1) {  
         @groups = sort(@groups);  
     }  
     return @groups;      return @groups;
 }  }
   
Line 6429  sub clutter { Line 6457  sub clutter {
      && $thisfn!~/\.(sequence|page)$/) {       && $thisfn!~/\.(sequence|page)$/) {
  $thisfn='/adm/coursedocs/showdoc'.$thisfn;   $thisfn='/adm/coursedocs/showdoc'.$thisfn;
     } else {      } else {
  &logthis("Got a blank emb style");  # &logthis("Got a blank emb style");
     }      }
  }   }
     }      }
Line 7250  all args are optional Line 7278  all args are optional
   
 =item *  =item *
   
   dumpstore($namespace,$udom,$uname,$regexp,$range) : 
   dumps the complete (or key matching regexp) namespace into a hash
   ($udom, $uname, $regexp, $range are optional) for a namespace that is
   normally &store()ed into
   
   $range should be either an integer '100' (give me the first 100
                                              matching records)
                 or be  two integers sperated by a - with no spaces
                    '30-50' (give me the 30th through the 50th matching
                             records)
   
   
   =item *
   
   putstore($namespace,$symb,$version,$storehash,$udomain,$uname) :
   replaces a &store() version of data with a replacement set of data
   for a particular resource in a namespace passed in the $storehash hash 
   reference
   
   =item *
   
 tmpstore($storehash,$symb,$namespace,$udom,$uname) : storage that  tmpstore($storehash,$symb,$namespace,$udom,$uname) : storage that
 works very similar to store/cstore, but all data is stored in a  works very similar to store/cstore, but all data is stored in a
 temporary location and can be reset using tmpreset, $storehash should  temporary location and can be reset using tmpreset, $storehash should
Line 7303  put($namespace,$storehash,$udom,$uname) Line 7352  put($namespace,$storehash,$udom,$uname)
   
 =item *  =item *
   
 putstore($namespace,$symb,$version,$storehash,$udomain,$uname) :  
   replaces a &store() version of data with a replacement set of data  
   for a particular resource in a namespace passed in the $storehash hash   
   reference  
   
 =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.716  
changed lines
  Added in v.1.726

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