[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.399 and 1.413

version 1.399, 2003/08/12 19:46:04 version 1.413, 2003/09/16 17:54:50
Line 76  qw(%perlvar %hostname %homecache %badSer Line 76  qw(%perlvar %hostname %homecache %badSer
    %libserv %pr %prp %metacache %packagetab %titlecache      %libserv %pr %prp %metacache %packagetab %titlecache 
    %courselogs %accesshash %userrolehash $processmarker $dumpcount      %courselogs %accesshash %userrolehash $processmarker $dumpcount 
    %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache      %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache 
    %domaindescription %domain_auth_def %domain_auth_arg_def $tmpdir);     %domaindescription %domain_auth_def %domain_auth_arg_def 
      %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir);
   
 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 243  sub critical { Line 245  sub critical {
     }      }
     return $answer;      return $answer;
 }  }
   
   #
   # -------------- Remove all key from the env that start witha lowercase letter
   #                (Which is always a lon-capa value)
   
   sub cleanenv {
   #    unless (defined(&Apache::exists_config_define("MODPERL2"))) { return; }
   #    unless (&Apache::exists_config_define("MODPERL2")) { return; }
       foreach my $key (keys(%ENV)) {
    if ($key =~ /^[a-z]/) {
       delete($ENV{$key});
    }
       }
   }
     
 # ------------------------------------------- Transfer profile into environment  # ------------------------------------------- Transfer profile into environment
   
Line 377  sub userload { Line 393  sub userload {
  my $curtime=time;   my $curtime=time;
  while ($filename=readdir(LONIDS)) {   while ($filename=readdir(LONIDS)) {
     if ($filename eq '.' || $filename eq '..') {next;}      if ($filename eq '.' || $filename eq '..') {next;}
     my ($atime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[8];      my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
     if ($curtime-$atime < 3600) { $numusers++; }      if ($curtime-$mtime < 3600) { $numusers++; }
  }   }
  closedir(LONIDS);   closedir(LONIDS);
     }      }
Line 424  sub spareserver { Line 440  sub spareserver {
     my $lowestserver=$loadpercent > $userloadpercent?      my $lowestserver=$loadpercent > $userloadpercent?
              $loadpercent :  $userloadpercent;               $loadpercent :  $userloadpercent;
     foreach $tryserver (keys %spareid) {      foreach $tryserver (keys %spareid) {
        my $loadans=reply('load',$tryserver);   my $loadans=reply('load',$tryserver);
        my $userloadans=reply('userload',$tryserver);   my $userloadans=reply('userload',$tryserver);
        if ($userloadans !~ /\d/) { $userloadans=0; }   if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
        my $answer=$loadans > $userloadans?      next; #didn't get a number from the server
                   $loadans :  $userloadans;   }
        if (($answer =~ /\d/) && ($answer<$lowestserver)) {   my $answer;
    $spareserver="http://$hostname{$tryserver}";   if ($loadans =~ /\d/) {
            $lowestserver=$answer;      if ($userloadans =~ /\d/) {
        }   #both are numbers, pick the bigger one
    $answer=$loadans > $userloadans?
       $loadans :  $userloadans;
       } else {
    $answer = $loadans;
       }
    } else {
       $answer = $userloadans;
    }
    if (($answer =~ /\d/) && ($answer<$lowestserver)) {
       $spareserver="http://$hostname{$tryserver}";
       $lowestserver=$answer;
    }
     }      }
     return $spareserver;      return $spareserver;
 }  }
Line 1216  sub courseacclog { Line 1244  sub courseacclog {
     my $fnsymb=shift;      my $fnsymb=shift;
     unless ($ENV{'request.course.id'}) { return ''; }      unless ($ENV{'request.course.id'}) { return ''; }
     my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'};      my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'};
     if ($fnsymb=~/(problem|exam|quiz|assess|survey|form)$/) {      if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|page)$/) {
         $what.=':POST';          $what.=':POST';
  foreach (keys %ENV) {   foreach (keys %ENV) {
             if ($_=~/^form\.(.*)/) {              if ($_=~/^form\.(.*)/) {
Line 1284  sub get_course_adv_roles { Line 1312  sub get_course_adv_roles {
     return %returnhash;      return %returnhash;
 }  }
   
   sub get_my_roles {
       my ($uname,$udom)=@_;
       unless (defined($uname)) { $uname=$ENV{'user.name'}; }
       unless (defined($udom)) { $udom=$ENV{'user.domain'}; }
       my %dumphash=
               &dump('nohist_userroles',$udom,$uname);
       my %returnhash=();
       my $now=time;
       foreach (keys %dumphash) {
    my ($tend,$tstart)=split(/\:/,$dumphash{$_});
           if (($tstart) && ($tstart<0)) { next; }
           if (($tend) && ($tend<$now)) { next; }
           if (($tstart) && ($now<$tstart)) { next; }
           my ($role,$username,$domain,$section)=split(/\:/,$_);
    $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
        }
       return %returnhash;
   }
   
 # ----------------------------------------------------- Frontpage Announcements  # ----------------------------------------------------- Frontpage Announcements
 #  #
 #  #
Line 2105  sub dump { Line 2152  sub dump {
    return %returnhash;     return %returnhash;
 }  }
   
   # -------------------------------------------------------------- keys interface
   
   sub getkeys {
      my ($namespace,$udomain,$uname)=@_;
      if (!$udomain) { $udomain=$ENV{'user.domain'}; }
      if (!$uname) { $uname=$ENV{'user.name'}; }
      my $uhome=&homeserver($uname,$udomain);
      my $rep=reply("keys:$udomain:$uname:$namespace",$uhome);
      my @keyarray=();
      foreach (split(/\&/,$rep)) {
         push (@keyarray,&unescape($_));
      }
      return @keyarray;
   }
   
 # --------------------------------------------------------------- currentdump  # --------------------------------------------------------------- currentdump
 sub currentdump {  sub currentdump {
    my ($courseid,$sdom,$sname)=@_;     my ($courseid,$sdom,$sname)=@_;
Line 2237  sub customaccess { Line 2299  sub customaccess {
             $access=($effect eq 'allow');              $access=($effect eq 'allow');
             last;              last;
         }          }
    if ($realm eq '' && $role eq '') {
               $access=($effect eq 'allow');
    }
     }      }
     return $access;      return $access;
 }  }
Line 2541  sub is_on_map { Line 2606  sub is_on_map {
     if ($match) {      if ($match) {
  return (1,$1);   return (1,$1);
     } else {      } else {
  return (0,0);   my ($name,$ext)=($filename=~/^(.+)\.(\w+)$/);
           $ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
          /\&(\Q$name\E\.\d+\.$ext)\:([\d\|]+)\&/;
    return (0,$2,$pathname.'/'.$1);
     }      }
 }  }
   
Line 2775  sub modifyuser { Line 2843  sub modifyuser {
              ' in domain '.$ENV{'request.role.domain'});               ' in domain '.$ENV{'request.role.domain'});
     my $uhome=&homeserver($uname,$udom,'true');      my $uhome=&homeserver($uname,$udom,'true');
 # ----------------------------------------------------------------- Create User  # ----------------------------------------------------------------- Create User
     if (($uhome eq 'no_host') && ($umode) && ($upass)) {      if (($uhome eq 'no_host') && 
    (($umode && $upass) || ($umode eq 'localauth'))) {
         my $unhome='';          my $unhome='';
         if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) {           if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) { 
             $unhome = $desiredhome;              $unhome = $desiredhome;
Line 3115  sub dirlist { Line 3184  sub dirlist {
 # when it was last modified.  It will also return an error of -1  # when it was last modified.  It will also return an error of -1
 # if an error occurs  # if an error occurs
   
   ##
   ## FIXME: This subroutine assumes its caller knows something about the
   ## directory structure of the home server for the student ($root).
   ## Not a good assumption to make.  Since this is for looking up files
   ## in user directories, the full path should be constructed by lond, not
   ## whatever machine we request data from.
   ##
 sub GetFileTimestamp {  sub GetFileTimestamp {
     my ($studentDomain,$studentName,$filename,$root)=@_;      my ($studentDomain,$studentName,$filename,$root)=@_;
     $studentDomain=~s/\W//g;      $studentDomain=~s/\W//g;
Line 3360  sub EXT { Line 3436  sub EXT {
 # ----------------------------------------------------- Cascading lookup scheme  # ----------------------------------------------------- Cascading lookup scheme
     if (!$symbparm) { $symbparm=&symbread(); }      if (!$symbparm) { $symbparm=&symbread(); }
     my $symbp=$symbparm;      my $symbp=$symbparm;
     my $mapp=(split(/\_\_\_/,$symbp))[0];      my $mapp=(&decode_symb($symbp))[0];
   
     my $symbparm=$symbp.'.'.$spacequalifierrest;      my $symbparm=$symbp.'.'.$spacequalifierrest;
     my $mapparm=$mapp.'___(all).'.$spacequalifierrest;      my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
Line 3439  sub EXT { Line 3515  sub EXT {
  my $filename;   my $filename;
  if (!$symbparm) { $symbparm=&symbread(); }   if (!$symbparm) { $symbparm=&symbread(); }
  if ($symbparm) {   if ($symbparm) {
     $filename=(split(/\_\_\_/,$symbparm))[2];      $filename=(&decode_symb($symbparm))[2];
  } else {   } else {
     $filename=$ENV{'request.filename'};      $filename=$ENV{'request.filename'};
  }   }
Line 3535  sub metadata { Line 3611  sub metadata {
         if ($liburi) {          if ($liburi) {
     $liburi=&declutter($liburi);      $liburi=&declutter($liburi);
             $filename=$liburi;              $filename=$liburi;
         }          } else {
       delete($metacache{$uri.':packages'});
    }
         my %metathesekeys=();          my %metathesekeys=();
         unless ($filename=~/\.meta$/) { $filename.='.meta'; }          unless ($filename=~/\.meta$/) { $filename.='.meta'; }
  my $metastring=&getfile(&filelocation('',&clutter($filename)));   my $metastring=&getfile(&filelocation('',&clutter($filename)));
         my $parser=HTML::LCParser->new(\$metastring);          my $parser=HTML::LCParser->new(\$metastring);
         my $token;          my $token;
         undef %metathesekeys;          undef %metathesekeys;
  delete($metacache{$uri.':packages'});  
         while ($token=$parser->get_token) {          while ($token=$parser->get_token) {
     if ($token->[0] eq 'S') {      if ($token->[0] eq 'S') {
  if (defined($token->[2]->{'package'})) {   if (defined($token->[2]->{'package'})) {
Line 3713  sub gettitle { Line 3790  sub gettitle {
     delete($titlecache{$symb});      delete($titlecache{$symb});
  }   }
     }      }
     my ($map,$resid,$url)=split(/\_\_\_/,$symb);      my ($map,$resid,$url)=&decode_symb($symb);
     my $title='';      my $title='';
     my %bighash;      my %bighash;
     if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',      if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
Line 3759  sub symbverify { Line 3836  sub symbverify {
 # 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; }
 # check URL part  # check URL part
     my ($map,$resid,$url)=split(/\_\_\_/,$symb);      my ($map,$resid,$url)=&decode_symb($symb);
     unless (&symbclean($url) eq &symbclean($thisfn)) { return 0; }      unless (&symbclean($url) eq &symbclean($thisfn)) { return 0; }
   
     $symb=&symbclean($symb);      $symb=&symbclean($symb);
Line 3802  sub symbclean { Line 3879  sub symbclean {
     return $symb;      return $symb;
 }  }
   
   # ---------------------------------------------- Split symb to find map and url
   
   sub decode_symb {
       my ($map,$resid,$url)=split(/\_\_\_/,shift);
       return (&fixversion($map),$resid,&fixversion($url));
   }
   
   sub fixversion {
       my $fn=shift;
       if ($fn=~/^(adm|uploaded|public)/) { return $fn; }
       my ($match,$cond,$versioned)=&is_on_map($fn);
       unless ($match) {
    $fn=$versioned;
       }
       return $fn;
   }
   
 # ------------------------------------------------------ Return symb list entry  # ------------------------------------------------------ Return symb list entry
   
 sub symbread {  sub symbread {
Line 4148  BEGIN { Line 4242  BEGIN {
            next if (/^(\#|\s*$)/);             next if (/^(\#|\s*$)/);
 #           next if /^\#/;  #           next if /^\#/;
            chomp;             chomp;
            my ($domain, $domain_description, $def_auth, $def_auth_arg)             my ($domain, $domain_description, $def_auth, $def_auth_arg,
                = split(/:/,$_,4);         $def_lang, $city, $longi, $lati) = split(/:/,$_);
            $domain_auth_def{$domain}=$def_auth;     $domain_auth_def{$domain}=$def_auth;
            $domain_auth_arg_def{$domain}=$def_auth_arg;             $domain_auth_arg_def{$domain}=$def_auth_arg;
            $domaindescription{$domain}=$domain_description;     $domaindescription{$domain}=$domain_description;
      $domain_lang_def{$domain}=$def_lang;
      $domain_city{$domain}=$city;
      $domain_longi{$domain}=$longi;
      $domain_lati{$domain}=$lati;
   
 #          &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}");  #          &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}");
 #          &logthis("Domain.tab: $domain ".$domaindescription{$domain} );  #          &logthis("Domain.tab: $domain ".$domaindescription{$domain} );
        }         }
Removed from v.1.399  
changed lines
  Added in v.1.413

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