[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.299 and 1.313

version 1.299, 2002/10/22 21:49:10 version 1.313, 2002/12/09 22:09:58
Line 77  use Apache::File; Line 77  use Apache::File;
 use LWP::UserAgent();  use LWP::UserAgent();
 use HTTP::Headers;  use HTTP::Headers;
 use vars   use vars 
 qw(%perlvar %hostname %homecache %badServerCache %hostip %spareid %hostdom   qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom 
    %libserv %pr %prp %metacache %packagetab      %libserv %pr %prp %metacache %packagetab %titlecache 
    %courselogs %accesshash $processmarker $dumpcount      %courselogs %accesshash $processmarker $dumpcount 
    %coursedombuf %coursehombuf %courseresdatacache %domaindescription);     %coursedombuf %coursehombuf %courseresdatacache 
      %domaindescription);
 use IO::Socket;  use IO::Socket;
 use GDBM_File;  use GDBM_File;
 use Apache::Constants qw(:common :http);  use Apache::Constants qw(:common :http);
Line 142  sub reply { Line 143  sub reply {
     unless (defined($hostname{$server})) { return 'no_such_host'; }      unless (defined($hostname{$server})) { return 'no_such_host'; }
     my $answer=subreply($cmd,$server);      my $answer=subreply($cmd,$server);
     if ($answer eq 'con_lost') {      if ($answer eq 'con_lost') {
        #sleep 5;           #sleep 5; 
        #$answer=subreply($cmd,$server);          #$answer=subreply($cmd,$server);
        #if ($answer eq 'con_lost') {          #if ($answer eq 'con_lost') {
  #   &logthis("Second attempt con_lost on $server");   #   &logthis("Second attempt con_lost on $server");
         #   my $peerfile="$perlvar{'lonSockDir'}/$server";          #   my $peerfile="$perlvar{'lonSockDir'}/$server";
         #   my $client=IO::Socket::UNIX->new(Peer    =>"$peerfile",          #   my $client=IO::Socket::UNIX->new(Peer    =>"$peerfile",
Line 215  sub critical { Line 216  sub critical {
             $middlename=substr($middlename,0,16);              $middlename=substr($middlename,0,16);
             $middlename=~s/\W//g;              $middlename=~s/\W//g;
             my $dfilename=              my $dfilename=
              "$perlvar{'lonSockDir'}/delayed/$now.$middlename.$server";        "$perlvar{'lonSockDir'}/delayed/$now.$dumpcount.$$.$middlename.$server";
               $dumpcount++;
             {              {
              my $dfh;               my $dfh;
              if ($dfh=Apache::File->new(">$dfilename")) {               if ($dfh=Apache::File->new(">$dfilename")) {
Line 727  sub currentversion { Line 729  sub currentversion {
   
 sub subscribe {  sub subscribe {
     my $fname=shift;      my $fname=shift;
       if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return ''; }
     my $author=$fname;      my $author=$fname;
     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;      $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
     my ($udom,$uname)=split(/\//,$author);      my ($udom,$uname)=split(/\//,$author);
Line 840  sub tokenwrapper { Line 843  sub tokenwrapper {
     if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) {      if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) {
  &appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'});   &appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'});
         return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri.          return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri.
                (($uri=~/\?/)?'&':'?').'token='.$token;                 (($uri=~/\?/)?'&':'?').'token='.$token.
                                  '&tokenissued='.$perlvar{'lonHostID'};
     } else {      } else {
  return '/adm/notfound.html';   return '/adm/notfound.html';
     }      }
Line 1542  sub coursedescription { Line 1546  sub coursedescription {
     $courseid=~s/\_/\//g;      $courseid=~s/\_/\//g;
     my ($cdomain,$cnum)=split(/\//,$courseid);      my ($cdomain,$cnum)=split(/\//,$courseid);
     my $chome=&homeserver($cnum,$cdomain);      my $chome=&homeserver($cnum,$cdomain);
       my $normalid=$cdomain.'_'.$cnum;
       # need to always cache even if we get errors otherwise we keep 
       # trying and trying and trying to get the course description.
       my %envhash=();
       my %returnhash=();
       $envhash{'course.'.$normalid.'.last_cache'}=time;
     if ($chome ne 'no_host') {      if ($chome ne 'no_host') {
        my %returnhash=&dump('environment',$cdomain,$cnum);         %returnhash=&dump('environment',$cdomain,$cnum);
        if (!exists($returnhash{'con_lost'})) {         if (!exists($returnhash{'con_lost'})) {
            my $normalid=$cdomain.'_'.$cnum;  
            my %envhash=();  
            $returnhash{'home'}= $chome;             $returnhash{'home'}= $chome;
    $returnhash{'domain'} = $cdomain;     $returnhash{'domain'} = $cdomain;
    $returnhash{'num'} = $cnum;     $returnhash{'num'} = $cnum;
Line 1556  sub coursedescription { Line 1564  sub coursedescription {
            $returnhash{'url'}=&clutter($returnhash{'url'});             $returnhash{'url'}=&clutter($returnhash{'url'});
            $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.             $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.
        $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum;         $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum;
            $envhash{'course.'.$normalid.'.last_cache'}=time;  
            $envhash{'course.'.$normalid.'.home'}=$chome;             $envhash{'course.'.$normalid.'.home'}=$chome;
            $envhash{'course.'.$normalid.'.domain'}=$cdomain;             $envhash{'course.'.$normalid.'.domain'}=$cdomain;
            $envhash{'course.'.$normalid.'.num'}=$cnum;             $envhash{'course.'.$normalid.'.num'}=$cnum;
            &appenv(%envhash);  
            return %returnhash;  
        }         }
     }      }
     return ();      &appenv(%envhash);
       return %returnhash;
 }  }
   
 # -------------------------------------------------------- Get user privileges  # -------------------------------------------------------- Get user privileges
Line 1802  sub allowed { Line 1808  sub allowed {
   
     if ($priv eq 'bre') {      if ($priv eq 'bre') {
         my $copyright=&metadata($uri,'copyright');          my $copyright=&metadata($uri,'copyright');
  if ($copyright eq 'public') { return 'F'; }   if (($copyright eq 'public') && (!$ENV{'request.course.id'})) { 
              return 'F'; 
           }
         if ($copyright eq 'priv') {          if ($copyright eq 'priv') {
             $uri=~/([^\/]+)\/([^\/]+)\//;              $uri=~/([^\/]+)\/([^\/]+)\//;
     unless (($ENV{'user.name'} eq $2) && ($ENV{'user.domain'} eq $1)) {      unless (($ENV{'user.name'} eq $2) && ($ENV{'user.domain'} eq $1)) {
Line 2342  sub modifyuser { Line 2350  sub modifyuser {
        }         }
     }      }
 # -------------------------------------------------------------- Add names, etc  # -------------------------------------------------------------- Add names, etc
     my %names=&get('environment',      my @tmp=&get('environment',
    ['firstname','middlename','lastname','generation'],     ['firstname','middlename','lastname','generation'],
    $udom,$uname);     $udom,$uname);
     if ($names{'firstname'} =~ m/^error:.*/) { %names=(); }      my %names;
       if ($tmp[0] =~ m/^error:.*/) { 
           %names=(); 
       } else {
           %names = @tmp;
       }
     if ($first)  { $names{'firstname'}  = $first; }      if ($first)  { $names{'firstname'}  = $first; }
     if ($middle) { $names{'middlename'} = $middle; }      if ($middle) { $names{'middlename'} = $middle; }
     if ($last)   { $names{'lastname'}   = $last; }      if ($last)   { $names{'lastname'}   = $last; }
Line 2713  sub courseresdata { Line 2726  sub courseresdata {
  if ($tmp !~ /^(con_lost|error|no_such_host)/i) {   if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
     $courseresdatacache{$hashid.'.time'}=time;      $courseresdatacache{$hashid.'.time'}=time;
     $courseresdatacache{$hashid}=\%dumpreply;      $courseresdatacache{$hashid}=\%dumpreply;
    } elsif ($tmp =~ /^(con_lost|no_such_host)/) {
       return $tmp;
  }   }
     }      }
     foreach my $item (@which) {      foreach my $item (@which) {
Line 2839  sub EXT { Line 2854  sub EXT {
     my $courselevelm=$courseid.'.'.$mapparm;      my $courselevelm=$courseid.'.'.$mapparm;
   
 # ----------------------------------------------------------- first, check user  # ----------------------------------------------------------- first, check user
     my %resourcedata=&get('resourcedata',      #most student don't have any data set, check if there is some data
   [$courselevelr,$courselevelm,$courselevel],              #every thirty minutes
  $udom,$uname);      if (!
     if (($resourcedata{$courselevelr}!~/^error\:/) &&   (exists($ENV{'cache.studentresdata'})
  ($resourcedata{$courselevelr}!~/^con_lost/)) {      && (($ENV{'cache.studentresdata'}+1800) > time))) {
    my %resourcedata=&get('resourcedata',
  if ($resourcedata{$courselevelr}) {        [$courselevelr,$courselevelm,$courselevel],
     return $resourcedata{$courselevelr}; }        $udom,$uname);
  if ($resourcedata{$courselevelm}) {   my ($tmp)=keys(%resourcedata);
     return $resourcedata{$courselevelm}; }   if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) {
  if ($resourcedata{$courselevel}) {      if ($resourcedata{$courselevelr}) {
     return $resourcedata{$courselevel}; }   return $resourcedata{$courselevelr}; }
     } else {      if ($resourcedata{$courselevelm}) {
  if ($resourcedata{$courselevelr}!~/No such file/) {   return $resourcedata{$courselevelm}; }
     &logthis("<font color=blue>WARNING:".      if ($resourcedata{$courselevel}) {
      " Trying to get resource data for ".   return $resourcedata{$courselevel}; }
      $uname." at ".$udom.": ".   } else {
      $resourcedata{$courselevelr}."</font>");      if ($tmp!~/No such file/) {
    &logthis("<font color=blue>WARNING:".
    " Trying to get resource data for ".
    $uname." at ".$udom.": ".
    $tmp."</font>");
       } elsif ($tmp=~/error:No such file/) {
    $ENV{'cache.studentresdata'}=time;
    &appenv(('cache.studentresdata'=>
    $ENV{'cache.studentresdata'}));
       } elsif ($tmp =~ /^(con_lost|no_such_host)/) {
    return $tmp;
       }
  }   }
     }      }
   
Line 3096  sub metadata_generate_part0 { Line 3122  sub metadata_generate_part0 {
     }      }
 }  }
   
   # ------------------------------------------------- Get the title of a resource
   
   sub gettitle {
       my $urlsymb=shift;
       my $symb=&symbread($urlsymb);
       unless ($symb) {
    unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; }
           return &metadata($urlsymb,'title'); 
       }
       if ($titlecache{$symb}) { return $titlecache{$symb}; }
       my ($map,$resid,$url)=split(/\_\_\_/,$symb);
       my $title='';
       my %bighash;
       if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
                               &GDBM_READER(),0640)) {
           my $mapid=$bighash{'map_pc_'.&clutter($map)};
           $title=$bighash{'title_'.$mapid.'.'.$resid};
           untie %bighash;
       }
       if ($title) {
           $titlecache{$symb}=$title;
           return $title;
       } else {
    return &metadata($urlsymb,'title');
       }
   }
       
 # ------------------------------------------------- Update symbolic store links  # ------------------------------------------------- Update symbolic store links
   
 sub symblist {  sub symblist {
Line 3442  BEGIN { Line 3495  BEGIN {
     my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab");      my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab");
   
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
          next if ($configline =~ /^(\#|\s*$)/);
        chomp($configline);         chomp($configline);
        my ($id,$domain,$role,$name,$ip,$domdescr)=split(/:/,$configline);         my ($id,$domain,$role,$name,$ip,$domdescr)=split(/:/,$configline);
        if ($id && $domain && $role && $name && $ip) {         if ($id && $domain && $role && $name && $ip) {
  $hostname{$id}=$name;   $hostname{$id}=$name;
  $hostdom{$id}=$domain;   $hostdom{$id}=$domain;
  $hostip{$id}=$ip;   $hostip{$id}=$ip;
    $iphost{$ip}=$id;
  if ($domdescr) { $domaindescription{$domain}=$domdescr; }   if ($domdescr) { $domaindescription{$domain}=$domdescr; }
  if ($role eq 'library') { $libserv{$id}=$name; }   if ($role eq 'library') { $libserv{$id}=$name; }
        } else {         } else {
Removed from v.1.299  
changed lines
  Added in v.1.313

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