[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.697 and 1.707

version 1.697, 2006/01/11 08:24:21 version 1.707, 2006/02/07 16:21:05
Line 124  sub logperm { Line 124  sub logperm {
 # -------------------------------------------------- Non-critical communication  # -------------------------------------------------- Non-critical communication
 sub subreply {  sub subreply {
     my ($cmd,$server)=@_;      my ($cmd,$server)=@_;
     my $peerfile="$perlvar{'lonSockDir'}/$server";      my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server};
     #      #
     #  With loncnew process trimming, there's a timing hole between lonc server      #  With loncnew process trimming, there's a timing hole between lonc server
     #  process exit and the master server picking up the listen on the AF_UNIX      #  process exit and the master server picking up the listen on the AF_UNIX
Line 152  sub subreply { Line 152  sub subreply {
     }      }
     my $answer;      my $answer;
     if ($client) {      if ($client) {
  print $client "$cmd\n";   print $client "sethost:$server:$cmd\n";
  $answer=<$client>;   $answer=<$client>;
  if (!$answer) { $answer="con_lost"; }   if (!$answer) { $answer="con_lost"; }
  chomp($answer);   chomp($answer);
Line 947  sub userenvironment { Line 947  sub userenvironment {
 sub studentphoto {  sub studentphoto {
     my ($udom,$unam,$ext) = @_;      my ($udom,$unam,$ext) = @_;
     my $home=&Apache::lonnet::homeserver($unam,$udom);      my $home=&Apache::lonnet::homeserver($unam,$udom);
     my $ret=&Apache::lonnet::reply("studentphoto:$udom:$unam:$ext",$home);      if (defined($env{'request.course.id'})) {
     my $url="/uploaded/$udom/$unam/internal/studentphoto.".$ext;          if ($env{'course.'.$env{'request.course.id'}.'.internal.showphotos'}) {
     if ($ret ne 'ok') {              if ($udom eq $env{'course.'.$env{'request.course.id'}.'.domain'}) {
  return '/adm/lonKaputt/lonlogo_broken.gif';                  return(&retrievestudentphoto($udom,$unam,$ext)); 
               } else {
                   my ($result,$perm_reqd)=
       &Apache::lonnet::auto_photo_permission($unam,$udom);
                   if ($result eq 'ok') {
                       if (!($perm_reqd eq 'yes')) {
                           return(&retrievestudentphoto($udom,$unam,$ext));
                       }
                   }
               }
           }
       } else {
           my ($result,$perm_reqd) = 
       &Apache::lonnet::auto_photo_permission($unam,$udom);
           if ($result eq 'ok') {
               if (!($perm_reqd eq 'yes')) {
                   return(&retrievestudentphoto($udom,$unam,$ext));
               }
           }
       }
       return '/adm/lonKaputt/lonlogo_broken.gif';
   }
   
   sub retrievestudentphoto {
       my ($udom,$unam,$ext,$type) = @_;
       my $home=&Apache::lonnet::homeserver($unam,$udom);
       my $ret=&Apache::lonnet::reply("studentphoto:$udom:$unam:$ext:$type",$home);
       if ($ret eq 'ok') {
           my $url="/uploaded/$udom/$unam/internal/studentphoto.$ext";
           if ($type eq 'thumbnail') {
               $url="/uploaded/$udom/$unam/internal/studentphoto_tn.$ext"; 
           }
           my $tokenurl=&Apache::lonnet::tokenwrapper($url);
           return $tokenurl;
       } else {
           if ($type eq 'thumbnail') {
               return '/adm/lonKaputt/genericstudent_tn.gif';
           } else { 
               return '/adm/lonKaputt/lonlogo_broken.gif';
           }
     }      }
     my $tokenurl=&Apache::lonnet::tokenwrapper($url);  
     return $tokenurl;  
 }  }
   
 # -------------------------------------------------------------------- New chat  # -------------------------------------------------------------------- New chat
Line 1358  sub finishuserfileupload { Line 1395  sub finishuserfileupload {
     }      }
 # Save the file  # Save the file
     {      {
  open(FH,'>'.$filepath.'/'.$file);   if (!open(FH,'>'.$filepath.'/'.$file)) {
  print FH $env{'form.'.$formname};      &logthis('Failed to create '.$filepath.'/'.$file);
       print STDERR ('Failed to create '.$filepath.'/'.$file."\n");
       return '/adm/notfound.html';
    }
    if (!print FH ($env{'form.'.$formname})) {
       &logthis('Failed to write to '.$filepath.'/'.$file);
       print STDERR ('Failed to write to '.$filepath.'/'.$file."\n");
       return '/adm/notfound.html';
    }
  close(FH);   close(FH);
     }      }
     if ($parser eq 'parse') {      if ($parser eq 'parse') {
Line 2785  sub del { Line 2830  sub del {
 # -------------------------------------------------------------- dump interface  # -------------------------------------------------------------- dump interface
   
 sub dump {  sub dump {
    my ($namespace,$udomain,$uname,$regexp)=@_;     my ($namespace,$udomain,$uname,$regexp,$range)=@_;
    if (!$udomain) { $udomain=$env{'user.domain'}; }     if (!$udomain) { $udomain=$env{'user.domain'}; }
    if (!$uname) { $uname=$env{'user.name'}; }     if (!$uname) { $uname=$env{'user.name'}; }
    my $uhome=&homeserver($uname,$udomain);     my $uhome=&homeserver($uname,$udomain);
Line 2794  sub dump { Line 2839  sub dump {
    } else {     } else {
        $regexp='.';         $regexp='.';
    }     }
    my $rep=reply("dump:$udomain:$uname:$namespace:$regexp",$uhome);     my $rep=reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
    my @pairs=split(/\&/,$rep);     my @pairs=split(/\&/,$rep);
    my %returnhash=();     my %returnhash=();
    foreach (@pairs) {     foreach (@pairs) {
       my ($key,$value)=split(/=/,$_);        my ($key,$value)=split(/=/,$_,2);
       $returnhash{unescape($key)}=&thaw_unescape($value);        $returnhash{unescape($key)}=&thaw_unescape($value);
    }     }
    return %returnhash;     return %returnhash;
Line 3073  sub customaccess { Line 3118  sub customaccess {
   
 sub allowed {  sub allowed {
     my ($priv,$uri,$symb)=@_;      my ($priv,$uri,$symb)=@_;
       my $ver_orguri=$uri;
     $uri=&deversion($uri);      $uri=&deversion($uri);
     my $orguri=$uri;      my $orguri=$uri;
     $uri=&declutter($uri);      $uri=&declutter($uri);
Line 3173  sub allowed { Line 3219  sub allowed {
                 $thisallowed.=$1;                  $thisallowed.=$1;
             }              }
         } else {          } else {
             my $refuri=$env{'httpref.'.$orguri};              my $refuri = $env{'httpref.'.$orguri} || $env{'httpref.'.$ver_orguri};
             if ($refuri) {              if ($refuri) {
                 if ($refuri =~ m|^/adm/|) {                  if ($refuri =~ m|^/adm/|) {
                     $thisallowed='F';                      $thisallowed='F';
Line 3686  sub auto_create_password { Line 3732  sub auto_create_password {
     return ($authparam,$create_passwd,$authchk);      return ($authparam,$create_passwd,$authchk);
 }  }
   
   sub auto_photo_permission {
       my ($cnum,$cdom,$students) = @_;
       my $homeserver = &homeserver($cnum,$cdom);
       my ($outcome,$perm_reqd,$conditions) = 
    split(/:/,&unescape(&reply('autophotopermission:'.$cdom,$homeserver)),3);
       return ($outcome,$perm_reqd,$conditions);
   }
   
   sub auto_checkphotos {
       my ($uname,$udom,$pid) = @_;
       my $homeserver = &homeserver($uname,$udom);
       my ($result,$resulttype);
       my $outcome = &unescape(&reply('autophotocheck:'.&escape($udom).':'.
      &escape($uname).':'.&escape($pid),
      $homeserver));
       if ($outcome) {
           ($result,$resulttype) = split(/:/,$outcome);
       } 
       return ($result,$resulttype);
   }
   
   sub auto_photochoice {
       my ($cnum,$cdom) = @_;
       my $homeserver = &homeserver($cnum,$cdom);
       my ($update,$comment) = split(/:/,&unescape(&reply('autophotochoice:'.
          &escape($cdom),
          $homeserver)));
       return ($update,$comment);
   }
   
   sub auto_photoupdate {
       my ($affiliatesref,$dom,$cnum,$photo) = @_;
       my $homeserver = &homeserver($cnum,$dom);
       my $host=$hostname{$homeserver};
       my $cmd = '';
       my $maxtries = 1;
       foreach (keys %{$affiliatesref}) {
           $cmd .= $_.'='.join(",",@{$$affiliatesref{$_}}).'%%';
       }
       $cmd =~ s/%%$//;
       $cmd = &escape($cmd);
       my $query = 'institutionalphotos';
       my $queryid=&reply("querysend:".$query.':'.$dom.':'.$cnum.':'.$cmd,$homeserver);
       unless ($queryid=~/^\Q$host\E\_/) {
           &logthis('institutionalphotos: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' and course: '.$cnum);
           return 'error: '.$queryid;
       }
       my $reply = &get_query_reply($queryid);
       my $tries = 1;
       while (($reply=~/^timeout/) && ($tries < $maxtries)) {
           $reply = &get_query_reply($queryid);
           $tries ++;
       }
       if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
           &logthis('institutionalphotos error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' course: '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
       } else {
           my @responses = split(/:/,$reply);
           my $outcome = shift(@responses); 
           foreach my $item (@responses) {
               my ($key,$value) = split(/=/,$item);
               $$photo{$key} = $value;
           }
           return $outcome;
       }
       return 'error';
   }
   
 sub auto_instcode_format {  sub auto_instcode_format {
     my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,$cat_order) = @_;      my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,$cat_order) = @_;
     my $courses = '';      my $courses = '';
Line 5042  sub metadata { Line 5155  sub metadata {
     # if it is a non metadata possible uri return quickly      # if it is a non metadata possible uri return quickly
     if (($uri eq '') ||       if (($uri eq '') || 
  (($uri =~ m|^/*adm/|) &&    (($uri =~ m|^/*adm/|) && 
      ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)       ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) ||
   && ($uri !~ m|^adm/coursedocs/|) && ($uri !~ m|^adm/wrapper/|)) ||  
         ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||          ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||
  ($uri =~ m|home/[^/]+/public_html/|)) {   ($uri =~ m|home/[^/]+/public_html/|)) {
  return undef;   return undef;
Line 5228  sub metadata { Line 5340  sub metadata {
  $metaentry{':keys'}=join(',',keys %metathesekeys);   $metaentry{':keys'}=join(',',keys %metathesekeys);
  &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);   &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
  $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);   $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);
  &do_cache_new('meta',$uri,\%metaentry,60*60*24);   &do_cache_new('meta',$uri,\%metaentry,60*60);
 # this is the end of "was not already recently cached  # this is the end of "was not already recently cached
     }      }
     return $metaentry{':'.$what};      return $metaentry{':'.$what};
Line 5324  sub get_slot { Line 5436  sub get_slot {
  $cdom=$env{'course.'.$courseid.'.domain'};   $cdom=$env{'course.'.$courseid.'.domain'};
  $cnum=$env{'course.'.$courseid.'.num'};   $cnum=$env{'course.'.$courseid.'.num'};
     }      }
     my %slotinfo=&get('slots',[$which],$cdom,$cnum);      my $key=join("\0",'slots',$cdom,$cnum,$which);
     &Apache::lonhomework::showhash(%slotinfo);      my %slotinfo;
     my ($tmp)=keys(%slotinfo);      if (exists($remembered{$key})) {
     if ($tmp=~/^error:/) { return (); }   $slotinfo{$which} = $remembered{$key};
       } else {
    %slotinfo=&get('slots',[$which],$cdom,$cnum);
    &Apache::lonhomework::showhash(%slotinfo);
    my ($tmp)=keys(%slotinfo);
    if ($tmp=~/^error:/) { return (); }
    $remembered{$key} = $slotinfo{$which};
       }
     if (ref($slotinfo{$which}) eq 'HASH') {      if (ref($slotinfo{$which}) eq 'HASH') {
  return %{$slotinfo{$which}};   return %{$slotinfo{$which}};
     }      }
Line 6067  sub filelocation { Line 6186  sub filelocation {
     my ($dir,$file) = @_;      my ($dir,$file) = @_;
     my $location;      my $location;
     $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces      $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces
   
       if ($file =~ m-^/adm/-) {
    $file=~s-^/adm/wrapper/-/-;
    $file=~s-^/adm/coursedocs/showdoc/-/-;
       }
     if ($file=~m:^/~:) { # is a contruction space reference      if ($file=~m:^/~:) { # is a contruction space reference
         $location = $file;          $location = $file;
         $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;          $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;
Line 6106  sub hreflocation { Line 6230  sub hreflocation {
     my ($dir,$file)=@_;      my ($dir,$file)=@_;
     unless (($file=~m-^http://-i) || ($file=~m-^/-)) {      unless (($file=~m-^http://-i) || ($file=~m-^/-)) {
  $file=filelocation($dir,$file);   $file=filelocation($dir,$file);
       } elsif ($file=~m-^/adm/-) {
    $file=~s-^/adm/wrapper/-/-;
    $file=~s-^/adm/coursedocs/showdoc/-/-;
     }      }
     if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) {      if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) {
  $file=~s-^\Q$perlvar{'lonDocRoot'}\E--;   $file=~s-^\Q$perlvar{'lonDocRoot'}\E--;
Line 6169  sub clutter { Line 6296  sub clutter {
  } else {   } else {
     my ($ext) = ($thisfn =~ /\.(\w+)$/);      my ($ext) = ($thisfn =~ /\.(\w+)$/);
     my $embstyle=&Apache::loncommon::fileembstyle($ext);      my $embstyle=&Apache::loncommon::fileembstyle($ext);
     if (($embstyle eq 'img')       if ($embstyle eq 'ssi'
    || ($embstyle eq 'hdn')
    || ($embstyle eq 'rat')
    || ($embstyle eq 'prv')
    || ($embstyle eq 'ign')) {
    #do nothing with these
       } elsif (($embstyle eq 'img') 
  || ($embstyle eq 'emb')   || ($embstyle eq 'emb')
  || ($embstyle eq 'wrp')) {   || ($embstyle eq 'wrp')) {
  $thisfn='/adm/wrapper'.$thisfn;   $thisfn='/adm/wrapper'.$thisfn;
     } elsif ($embstyle eq 'ssi') {      } elsif ($embstyle eq 'unk'
  #do nothing with these       && $thisfn!~/\.(sequence|page)$/) {
     } elsif ($thisfn!~/\.(sequence|page)$/) {  
  $thisfn='/adm/coursedocs/showdoc'.$thisfn;   $thisfn='/adm/coursedocs/showdoc'.$thisfn;
       } else {
    &logthis("Got a blank emb style");
     }      }
  }   }
     }      }
Line 7026  namesp ($udom and $uname are optional) Line 7160  namesp ($udom and $uname are optional)
   
 =item *  =item *
   
 dump($namespace,$udom,$uname,$regexp) :   dump($namespace,$udom,$uname,$regexp,$range) : 
 dumps the complete (or key matching regexp) namespace into a hash  dumps the complete (or key matching regexp) namespace into a hash
 ($udom, $uname and $regexp are optional)  ($udom, $uname, $regexp, $range are optional)
   
   $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 *  =item *
   
 inc($namespace,$store,$udom,$uname) : increments $store in $namespace.  inc($namespace,$store,$udom,$uname) : increments $store in $namespace.
Removed from v.1.697  
changed lines
  Added in v.1.707

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