[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.201 and 1.224

version 1.201, 2002/02/14 20:44:26 version 1.224, 2002/05/17 19:52:42
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 %hostip %spareid %hostdom   qw(%perlvar %hostname %homecache %badhomecache %hostip %spareid %hostdom 
    %libserv %pr %prp %metacache %packagetab      %libserv %pr %prp %metacache %packagetab 
    %courselogs %accesshash $processmarker $dumpcount      %courselogs %accesshash $processmarker $dumpcount 
    %coursedombuf %coursehombuf %courseresdatacache);     %coursedombuf %coursehombuf %courseresdatacache);
 use IO::Socket;  use IO::Socket;
 use GDBM_File;  use GDBM_File;
 use Apache::Constants qw(:common :http);  use Apache::Constants qw(:common :http);
 use HTML::TokeParser;  use HTML::LCParser;
 use Fcntl qw(:flock);  use Fcntl qw(:flock);
 my $readit;  my $readit;
   
Line 137  sub subreply { Line 137  sub subreply {
   
 sub reply {  sub reply {
     my ($cmd,$server)=@_;      my ($cmd,$server)=@_;
       unless (defined($hostname{$server})) { return 'no_such_host'; }
     my $answer=subreply($cmd,$server);      my $answer=subreply($cmd,$server);
     if ($answer eq 'con_lost') { $answer=subreply($cmd,$server); }      if ($answer eq 'con_lost') {
          sleep 5; 
          $answer=subreply($cmd,$server);
          if ($answer eq 'con_lost') {
      &logthis("Second attempt con_lost on $server");
              my $peerfile="$perlvar{'lonSockDir'}/$server";
              my $client=IO::Socket::UNIX->new(Peer    =>"$peerfile",
                                               Type    => SOCK_STREAM,
                                               Timeout => 10)
                         or return "con_lost";
              &logthis("Killing socket");
              print $client "close_connection_exit\n";
              sleep 5;
              $answer=subreply($cmd,$server);       
          }   
       }
     if (($answer=~/^refused/) || ($answer=~/^rejected/)) {      if (($answer=~/^refused/) || ($answer=~/^rejected/)) {
        &logthis("<font color=blue>WARNING:".         &logthis("<font color=blue>WARNING:".
                 " $cmd to $server returned $answer</font>");                  " $cmd to $server returned $answer</font>");
Line 348  sub spareserver { Line 364  sub spareserver {
     return $spareserver;      return $spareserver;
 }  }
   
   # --------------------------------------------- Try to change a user's password
   
   sub changepass {
       my ($uname,$udom,$currentpass,$newpass,$server)=@_;
       $currentpass = &escape($currentpass);
       $newpass     = &escape($newpass);
       my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass",
          $server);
       if (! $answer) {
    &logthis("No reply on password change request to $server ".
    "by $uname in domain $udom.");
       } elsif ($answer =~ "^ok") {
           &logthis("$uname in $udom successfully changed their password ".
    "on $server.");
       } elsif ($answer =~ "^pwchange_failure") {
    &logthis("$uname in $udom was unable to change their password ".
    "on $server.  The action was blocked by either lcpasswd ".
    "or pwchange");
       } elsif ($answer =~ "^non_authorized") {
           &logthis("$uname in $udom did not get their password correct when ".
    "attempting to change it on $server.");
       } elsif ($answer =~ "^auth_mode_error") {
           &logthis("$uname in $udom attempted to change their password despite ".
    "not being locally or internally authenticated on $server.");
       } elsif ($answer =~ "^unknown_user") {
           &logthis("$uname in $udom attempted to change their password ".
    "on $server but were unable to because $server is not ".
    "their home server.");
       } elsif ($answer =~ "^refused") {
    &logthis("$server refused to change $uname in $udom password because ".
    "it was sent an unencrypted request to change the password.");
       }
       return $answer;
   }
   
 # ----------------------- Try to determine user's current authentication scheme  # ----------------------- Try to determine user's current authentication scheme
   
 sub queryauthenticate {  sub queryauthenticate {
Line 431  sub authenticate { Line 482  sub authenticate {
   
 sub homeserver {  sub homeserver {
     my ($uname,$udom)=@_;      my ($uname,$udom)=@_;
   
     my $index="$uname:$udom";      my $index="$uname:$udom";
     if ($homecache{$index}) { return "$homecache{$index}"; }      if ($homecache{$index}) { 
           return "$homecache{$index}"; 
       }
     my $tryserver;      my $tryserver;
     foreach $tryserver (keys %libserv) {      foreach $tryserver (keys %libserv) {
           next if (exists($badhomecache{$index}->{$tryserver}));
  if ($hostdom{$tryserver} eq $udom) {   if ($hostdom{$tryserver} eq $udom) {
            my $answer=reply("home:$udom:$uname",$tryserver);             my $answer=reply("home:$udom:$uname",$tryserver);
            if ($answer eq 'found') {              if ($answer eq 'found') { 
       $homecache{$index}=$tryserver;                $homecache{$index}=$tryserver;
               return $tryserver;                 return $tryserver; 
    }             } else {
                  $badhomecache{$index}->{$tryserver}=1;
              }
          } else {
              $badhomecache{$index}->{$tryserver}=1;
        }         }
     }          }    
     return 'no_host';      return 'no_host';
Line 576  sub subscribe { Line 632  sub subscribe {
 sub repcopy {  sub repcopy {
     my $filename=shift;      my $filename=shift;
     $filename=~s/\/+/\//g;      $filename=~s/\/+/\//g;
       if ($filename=~/^\/home\/httpd\/html\/adm\//) { return OK; }
     my $transname="$filename.in.transfer";      my $transname="$filename.in.transfer";
     if ((-e $filename) || (-e $transname)) { return OK; }      if ((-e $filename) || (-e $transname)) { return OK; }
     my $remoteurl=subscribe($filename);      my $remoteurl=subscribe($filename);
Line 862  sub devalidate { Line 919  sub devalidate {
     }      }
 }  }
   
   sub arrayref2str {
     my ($arrayref) = @_;
     my $result='_ARRAY_REF__';
     foreach my $elem (@$arrayref) {
       if (ref($elem) eq 'ARRAY') {
         $result.=&escape(&arrayref2str($elem)).'&';
       } elsif (ref($elem) eq 'HASH') {
         $result.=&escape(&hashref2str($elem)).'&';
       } elsif (ref($elem)) {
         &logthis("Got a ref of ".(ref($elem))." skipping.");
       } else {
         $result.=&escape($elem).'&';
       }
     }
     $result=~s/\&$//;
     return $result;
   }
   
 sub hash2str {  sub hash2str {
   my (%hash)=@_;    my (%hash) = @_;
   my $result='';    my $result=&hashref2str(\%hash);
   foreach (keys %hash) { $result.=escape($_).'='.escape($hash{$_}).'&'; }    $result=~s/^_HASH_REF__//;
     return $result;
   }
   
   sub hashref2str {
     my ($hashref)=@_;
     my $result='_HASH_REF__';
     foreach (keys(%$hashref)) {
       if (ref($_) eq 'ARRAY') {
         $result.=&escape(&arrayref2str($_)).'=';
       } elsif (ref($_) eq 'HASH') {
         $result.=&escape(&hashref2str($_)).'=';
       } elsif (ref($_)) {
         &logthis("Got a ref of ".(ref($_))." skipping.");
       } else {
         $result.=&escape($_).'=';
       }
   
       if (ref($$hashref{$_}) eq 'ARRAY') {
         $result.=&escape(&arrayref2str($$hashref{$_})).'&';
       } elsif (ref($$hashref{$_}) eq 'HASH') {
         $result.=&escape(&hashref2str($$hashref{$_})).'&';
       } elsif (ref($$hashref{$_})) {
         &logthis("Got a ref of ".(ref($$hashref{$_}))." skipping.");
       } else {
         $result.=&escape($$hashref{$_}).'&';
       }
     }
   $result=~s/\&$//;    $result=~s/\&$//;
   return $result;    return $result;
 }  }
Line 875  sub str2hash { Line 977  sub str2hash {
   my %returnhash;    my %returnhash;
   foreach (split(/\&/,$string)) {    foreach (split(/\&/,$string)) {
     my ($name,$value)=split(/\=/,$_);      my ($name,$value)=split(/\=/,$_);
     $returnhash{&unescape($name)}=&unescape($value);      $name=&unescape($name);
       $value=&unescape($value);
       if ($value =~ /^_HASH_REF__/) {
         $value =~ s/^_HASH_REF__//;
         my %hash=&str2hash($value);
         $value=\%hash;
       } elsif ($value =~ /^_ARRAY_REF__/) {
         $value =~ s/^_ARRAY_REF__//;
         my @array=&str2array($value);
         $value=\@array;
       }
       $returnhash{$name}=$value;
   }    }
   return %returnhash;    return (%returnhash);
   }
   
   sub str2array {
     my ($string) = @_;
     my @returnarray;
     foreach my $value (split(/\&/,$string)) {
       $value=&unescape($value);
       if ($value =~ /^_HASH_REF__/) {
         $value =~ s/^_HASH_REF__//;
         my %hash=&str2hash($value);
         $value=\%hash;
       } elsif ($value =~ /^_ARRAY_REF__/) {
         $value =~ s/^_ARRAY_REF__//;
         my @array=&str2array($value);
         $value=\@array;
       }
       push(@returnarray,$value);
     }
     return (@returnarray);
 }  }
   
 # -------------------------------------------------------------------Temp Store  # -------------------------------------------------------------------Temp Store
Line 1012  sub store { Line 1144  sub store {
   
     if ($stuname) { $home=&homeserver($stuname,$domain); }      if ($stuname) { $home=&homeserver($stuname,$domain); }
   
       $symb=&symbclean($symb);
     if (!$symb) { unless ($symb=&symbread()) { return ''; } }      if (!$symb) { unless ($symb=&symbread()) { return ''; } }
   
     &devalidate($symb);      &devalidate($symb);
Line 1042  sub cstore { Line 1175  sub cstore {
   
     if ($stuname) { $home=&homeserver($stuname,$domain); }      if ($stuname) { $home=&homeserver($stuname,$domain); }
   
       $symb=&symbclean($symb);
     if (!$symb) { unless ($symb=&symbread()) { return ''; } }      if (!$symb) { unless ($symb=&symbread()) { return ''; } }
   
     &devalidate($symb);      &devalidate($symb);
Line 1077  sub restore { Line 1211  sub restore {
     if (!$symb) {      if (!$symb) {
       unless ($symb=escape(&symbread())) { return ''; }        unless ($symb=escape(&symbread())) { return ''; }
     } else {      } else {
       $symb=&escape($symb);        $symb=&escape(&symbclean($symb));
     }      }
     if (!$namespace) {       if (!$namespace) { 
        unless ($namespace=$ENV{'request.course.id'}) {          unless ($namespace=$ENV{'request.course.id'}) { 
Line 1733  sub modifyuserauth { Line 1867  sub modifyuserauth {
   
 # --------------------------------------------------------------- Modify a user  # --------------------------------------------------------------- Modify a user
   
   
 sub modifyuser {  sub modifyuser {
     my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,      my ($udom,    $uname, $uid,
         $forceid)=@_;          $umode,   $upass, $first,
           $middle,  $last,  $gene,
           $forceid, $desiredhome)=@_;
     $udom=~s/\W//g;      $udom=~s/\W//g;
     $uname=~s/\W//g;      $uname=~s/\W//g;
     &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.      &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
              $umode.', '.$first.', '.$middle.', '.               $umode.', '.$first.', '.$middle.', '.
      $last.', '.$gene.'(forceid: '.$forceid.') by '.       $last.', '.$gene.'(forceid: '.$forceid.')'.
              $ENV{'user.name'}.' at '.$ENV{'user.domain'});                 (defined($desiredhome) ? ' desiredhome = '.$desiredhome :
                                        ' desiredhome not specified'). 
                ' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'});
     my $uhome=&homeserver($uname,$udom);      my $uhome=&homeserver($uname,$udom);
 # ----------------------------------------------------------------- Create User  # ----------------------------------------------------------------- Create User
     if (($uhome eq 'no_host') && ($umode) && ($upass)) {      if (($uhome eq 'no_host') && ($umode) && ($upass)) {
         my $unhome='';          my $unhome='';
  if ($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $udom) {          if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) { 
               $unhome = $desiredhome;
    } elsif($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $udom) {
     $unhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};      $unhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};
         } else {          } else { # load balancing routine for determining $unhome
             my $tryserver;              my $tryserver;
             my $loadm=10000000;              my $loadm=10000000;
             foreach $tryserver (keys %libserv) {              foreach $tryserver (keys %libserv) {
Line 1763  sub modifyuser { Line 1902  sub modifyuser {
     }      }
         }          }
         if (($unhome eq '') || ($unhome eq 'no_host')) {          if (($unhome eq '') || ($unhome eq 'no_host')) {
     return 'error: find home';      return 'error: unable to find a home server for '.$uname.
                      ' in domain '.$udom;
         }          }
         my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':'.$umode.':'.          my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':'.$umode.':'.
                          &escape($upass),$unhome);                           &escape($upass),$unhome);
Line 1774  sub modifyuser { Line 1914  sub modifyuser {
         if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) {          if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) {
     return 'error: verify home';      return 'error: verify home';
         }          }
     }      }   # End of creation of new user
 # ---------------------------------------------------------------------- Add ID  # ---------------------------------------------------------------------- Add ID
     if ($uid) {      if ($uid) {
        $uid=~tr/A-Z/a-z/;         $uid=~tr/A-Z/a-z/;
Line 1792  sub modifyuser { Line 1932  sub modifyuser {
     my %names=&get('environment',      my %names=&get('environment',
    ['firstname','middlename','lastname','generation'],     ['firstname','middlename','lastname','generation'],
    $udom,$uname);     $udom,$uname);
       if ($names{'firstname'} =~ m/^error:.*/) { %names=(); }
     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 1809  sub modifyuser { Line 1950  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)=@_;          $end,$start,$forceid,$desiredhome)=@_;
     my $cid='';      my $cid='';
     unless ($cid=$ENV{'request.course.id'}) {      unless ($cid=$ENV{'request.course.id'}) {
  return 'not_in_class';   return 'not_in_class';
     }      }
 # --------------------------------------------------------------- Make the user  # --------------------------------------------------------------- Make the user
     my $reply=&modifyuser      my $reply=&modifyuser
  ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid);   ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid,
            $desiredhome);
     unless ($reply eq 'ok') { return $reply; }      unless ($reply eq 'ok') { return $reply; }
     my $uhome=&homeserver($uname,$udom);      my $uhome=&homeserver($uname,$udom);
     if (($uhome eq '') || ($uhome eq 'no_host')) {       if (($uhome eq '') || ($uhome eq 'no_host')) { 
Line 2059  sub courseresdata { Line 2201  sub courseresdata {
 # --------------------------------------------------------- Value of a Variable  # --------------------------------------------------------- Value of a Variable
   
 sub EXT {  sub EXT {
     my ($varname,$symbparm)=@_;      my ($varname,$symbparm,$udom,$uname)=@_;
   
     unless ($varname) { return ''; }      unless ($varname) { return ''; }
   
       #get real user name/domain, courseid and symb
       my $courseid;
       if (!($uname && $udom)) {
         (my $cursymb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();
         if (!$symbparm) { $symbparm=$cursymb; }
       } else {
    $courseid=$ENV{'request.course.id'};
       }
   
     my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);      my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);
     my $rest;      my $rest;
     if ($therest[0]) {      if ($therest[0]) {
Line 2075  sub EXT { Line 2228  sub EXT {
     if ($realm eq 'user') {      if ($realm eq 'user') {
 # --------------------------------------------------------------- user.resource  # --------------------------------------------------------------- user.resource
  if ($space eq 'resource') {   if ($space eq 'resource') {
     my %restored=&restore();      my %restored=&restore(undef,undef,$udom,$uname);
             return $restored{$qualifierrest};              return $restored{$qualifierrest};
 # ----------------------------------------------------------------- user.access  # ----------------------------------------------------------------- user.access
         } elsif ($space eq 'access') {          } elsif ($space eq 'access') {
       # FIXME - not supporting calls for a specific user
             return &allowed($qualifier,$rest);              return &allowed($qualifier,$rest);
 # ------------------------------------------ user.preferences, user.environment  # ------------------------------------------ user.preferences, user.environment
         } elsif (($space eq 'preferences') || ($space eq 'environment')) {          } elsif (($space eq 'preferences') || ($space eq 'environment')) {
             return $ENV{join('.',('environment',$qualifierrest))};      if (($uname eq $ENV{'user.name'}) &&
    ($udom eq $ENV{'user.domain'})) {
    return $ENV{join('.',('environment',$qualifierrest))};
       } else {
    my %returnhash=&userenvironment($udom,$uname,$qualifierrest);
    return $returnhash{$qualifierrest};
       }
 # ----------------------------------------------------------------- user.course  # ----------------------------------------------------------------- user.course
         } elsif ($space eq 'course') {          } elsif ($space eq 'course') {
       # FIXME - not supporting calls for a specific user
             return $ENV{join('.',('request.course',$qualifier))};              return $ENV{join('.',('request.course',$qualifier))};
 # ------------------------------------------------------------------- user.role  # ------------------------------------------------------------------- user.role
         } elsif ($space eq 'role') {          } elsif ($space eq 'role') {
       # FIXME - not supporting calls for a specific user
             my ($role,$where)=split(/\./,$ENV{'request.role'});              my ($role,$where)=split(/\./,$ENV{'request.role'});
             if ($qualifier eq 'value') {              if ($qualifier eq 'value') {
  return $role;   return $role;
Line 2096  sub EXT { Line 2258  sub EXT {
             }              }
 # ----------------------------------------------------------------- user.domain  # ----------------------------------------------------------------- user.domain
         } elsif ($space eq 'domain') {          } elsif ($space eq 'domain') {
             return $ENV{'user.domain'};              return $udom;
 # ------------------------------------------------------------------- user.name  # ------------------------------------------------------------------- user.name
         } elsif ($space eq 'name') {          } elsif ($space eq 'name') {
             return $ENV{'user.name'};              return $uname;
 # ---------------------------------------------------- Any other user namespace  # ---------------------------------------------------- Any other user namespace
         } else {          } else {
             my $item=($rest)?$qualifier.'.'.$rest:$qualifier;              my $item=($rest)?$qualifier.'.'.$rest:$qualifier;
Line 2116  sub EXT { Line 2278  sub EXT {
         }          }
     } elsif ($realm eq 'course') {      } elsif ($realm eq 'course') {
 # ---------------------------------------------------------- course.description  # ---------------------------------------------------------- course.description
         return $ENV{'course.'.$ENV{'request.course.id'}.'.'.          return $ENV{'course.'.$courseid.'.'.$spacequalifierrest};
                               $spacequalifierrest};  
     } elsif ($realm eq 'resource') {      } elsif ($realm eq 'resource') {
        if ($ENV{'request.course.id'}) {  
   
 #   print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;   if ($courseid eq $ENV{'request.course.id'}) {
   
       #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
   
 # ----------------------------------------------------- Cascading lookup scheme  # ----------------------------------------------------- Cascading lookup scheme
          my $symbp;      if (!$symbparm) { $symbparm=&symbread(); }
          if ($symbparm) {      my $symbp=$symbparm;
             $symbp=$symbparm;      my $mapp=(split(/\_\_\_/,$symbp))[0];
  } else {  
             $symbp=&symbread();      my $symbparm=$symbp.'.'.$spacequalifierrest;
          }                  my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
          my $mapp=(split(/\_\_\_/,$symbp))[0];  
       my $section;
          my $symbparm=$symbp.'.'.$spacequalifierrest;      if (($ENV{'user.name'} eq $uname) &&
          my $mapparm=$mapp.'___(all).'.$spacequalifierrest;   ($ENV{'user.domain'} eq $udom)) {
    $section={'request.course.sec'};
          my $seclevel=      } else {
             $ENV{'request.course.id'}.'.['.   $section=&usection($udom,$uname,$courseid);
  $ENV{'request.course.sec'}.'].'.$spacequalifierrest;      }
          my $seclevelr=  
             $ENV{'request.course.id'}.'.['.  
  $ENV{'request.course.sec'}.'].'.$symbparm;  
          my $seclevelm=  
             $ENV{'request.course.id'}.'.['.  
  $ENV{'request.course.sec'}.'].'.$mapparm;  
   
          my $courselevel=  
             $ENV{'request.course.id'}.'.'.$spacequalifierrest;  
          my $courselevelr=  
             $ENV{'request.course.id'}.'.'.$symbparm;  
          my $courselevelm=  
             $ENV{'request.course.id'}.'.'.$mapparm;  
   
 # ----------------------------------------------------------- first, check user      my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
          my %resourcedata=get('resourcedata',      my $seclevelr=$courseid.'.['.$section.'].'.$symbparm;
                            [$courselevelr,$courselevelm,$courselevel]);      my $seclevelm=$courseid.'.['.$section.'].'.$mapparm;
          if (($resourcedata{$courselevelr}!~/^error\:/) &&  
              ($resourcedata{$courselevelr}!~/^con_lost/)) {      my $courselevel=$courseid.'.'.$spacequalifierrest;
       my $courselevelr=$courseid.'.'.$symbparm;
          if ($resourcedata{$courselevelr}) {       my $courselevelm=$courseid.'.'.$mapparm;
             return $resourcedata{$courselevelr}; }  
          if ($resourcedata{$courselevelm}) {   
             return $resourcedata{$courselevelm}; }  
          if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; }  
   
       } else {  # ----------------------------------------------------------- first, check user
   if ($resourcedata{$courselevelr}!~/No such file/) {      my %resourcedata=&get('resourcedata',
     &logthis("<font color=blue>WARNING:".    [$courselevelr,$courselevelm,$courselevel],
    " Trying to get resource data for ".$ENV{'user.name'}." at "   $udom,$uname);
                    .$ENV{'user.domain'}.": ".$resourcedata{$courselevelr}.      if (($resourcedata{$courselevelr}!~/^error\:/) &&
                  "</font>");   ($resourcedata{$courselevelr}!~/^con_lost/)) {
   }  
       }   if ($resourcedata{$courselevelr}) {
       return $resourcedata{$courselevelr}; }
    if ($resourcedata{$courselevelm}) {
       return $resourcedata{$courselevelm}; }
    if ($resourcedata{$courselevel}) {
       return $resourcedata{$courselevel}; }
       } else {
    if ($resourcedata{$courselevelr}!~/No such file/) {
       &logthis("<font color=blue>WARNING:".
        " Trying to get resource data for ".
        $uname." at ".$udom.": ".
        $resourcedata{$courselevelr}."</font>");
    }
       }
   
 # -------------------------------------------------------- second, check course  # -------------------------------------------------------- second, check course
   
         my $coursereply=&courseresdata(      my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'},
                         $ENV{'course.'.$ENV{'request.course.id'}.'.num'},    $ENV{'course.'.$courseid.'.domain'},
                         $ENV{'course.'.$ENV{'request.course.id'}.'.domain'},    ($seclevelr,$seclevelm,$seclevel,
                         ($seclevelr,$seclevelm,$seclevel,     $courselevelr,$courselevelm,
                          $courselevelr,$courselevelm,$courselevel));     $courselevel));
         if ($coursereply) { return $coursereply; }      if ($coursereply) { return $coursereply; }
   
 # ------------------------------------------------------ third, check map parms  # ------------------------------------------------------ third, check map parms
        my %parmhash=();      my %parmhash=();
        my $thisparm='';             my $thisparm='';
        if (tie(%parmhash,'GDBM_File',      if (tie(%parmhash,'GDBM_File',
           $ENV{'request.course.fn'}.'_parms.db',&GDBM_READER,0640)) {      $ENV{'request.course.fn'}.'_parms.db',
            $thisparm=$parmhash{$symbparm};      &GDBM_READER,0640)) {
    untie(%parmhash);   $thisparm=$parmhash{$symbparm};
        }   untie(%parmhash);
        if ($thisparm) { return $thisparm; }      }
      }      if ($thisparm) { return $thisparm; }
         }
 # --------------------------------------------- last, look in resource metadata  # --------------------------------------------- last, look in resource metadata
   
       $spacequalifierrest=~s/\./\_/;   $spacequalifierrest=~s/\./\_/;
       my $metadata=&metadata($ENV{'request.filename'},$spacequalifierrest);   my $metadata=&metadata($ENV{'request.filename'},$spacequalifierrest);
       if ($metadata) { return $metadata; }   if ($metadata) { return $metadata; }
       $metadata=&metadata($ENV{'request.filename'},   $metadata=&metadata($ENV{'request.filename'},
                                          'parameter_'.$spacequalifierrest);      'parameter_'.$spacequalifierrest);
       if ($metadata) { return $metadata; }   if ($metadata) { return $metadata; }
   
 # ------------------------------------------------------------------ Cascade up  # ------------------------------------------------------------------ Cascade up
    unless ($space eq '0') {
       unless ($space eq '0') {      my ($part,$id)=split(/\_/,$space);
           my ($part,$id)=split(/\_/,$space);      if ($id) {
           if ($id) {   my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
       my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,       $symbparm,$udom,$uname);
                                    $symbparm);   if ($partgeneral) { return $partgeneral; }
               if ($partgeneral) { return $partgeneral; }      } else {
           } else {   my $resourcegeneral=&EXT('resource.0.'.$qualifierrest,
               my $resourcegeneral=&EXT('resource.0.'.$qualifierrest,   $symbparm,$udom,$uname);
                                        $symbparm);   if ($resourcegeneral) { return $resourcegeneral; }
               if ($resourcegeneral) { return $resourcegeneral; }      }
           }   }
       }  
   
 # ---------------------------------------------------- Any other user namespace  # ---------------------------------------------------- Any other user namespace
     } elsif ($realm eq 'environment') {      } elsif ($realm eq 'environment') {
 # ----------------------------------------------------------------- environment  # ----------------------------------------------------------------- environment
         return $ENV{'environment.'.$spacequalifierrest};   if (($uname eq $ENV{'user.name'})&&($udom eq $ENV{'user.domain'})) {
       return $ENV{'environment.'.$spacequalifierrest};
    } else {
       my %returnhash=&userenvironment($udom,$uname,
       $spacequalifierrest);
       return $returnhash{$spacequalifierrest};
    }
     } elsif ($realm eq 'system') {      } elsif ($realm eq 'system') {
 # ----------------------------------------------------------------- system.time  # ----------------------------------------------------------------- system.time
  if ($space eq 'time') {   if ($space eq 'time') {
Line 2255  sub metadata { Line 2417  sub metadata {
         my %metathesekeys=();          my %metathesekeys=();
         unless ($filename=~/\.meta$/) { $filename.='.meta'; }          unless ($filename=~/\.meta$/) { $filename.='.meta'; }
  my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename);   my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename);
         my $parser=HTML::TokeParser->new(\$metastring);          my $parser=HTML::LCParser->new(\$metastring);
         my $token;          my $token;
         undef %metathesekeys;          undef %metathesekeys;
         while ($token=$parser->get_token) {          while ($token=$parser->get_token) {
Line 2344  sub metadata { Line 2506  sub metadata {
   $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};    $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};
               }                }
               unless (                unless (
                  $metacache{$uri.':'.$unikey}=$parser->get_text('/'.$entry)                   $metacache{$uri.':'.$unikey}=&HTML::Entities::decode($parser->get_text('/'.$entry))
       ) { $metacache{$uri.':'.$unikey}=        ) { $metacache{$uri.':'.$unikey}=
       $metacache{$uri.':'.$unikey.'.default'};        $metacache{$uri.':'.$unikey.'.default'};
       }        }
Line 2382  sub symblist { Line 2544  sub symblist {
     return 'error';      return 'error';
 }  }
   
   # --------------------------------------------------------------- Verify a symb
   
   sub symbverify {
       my ($symb,$thisfn)=@_;
       $thisfn=&declutter($thisfn);
   # direct jump to resource in page or to a sequence - will construct own symbs
       if ($thisfn=~/\.(page|sequence)$/) { return 1; }
   # check URL part
       my ($map,$resid,$url)=split(/\_\_\_/,$symb);
       unless (&symbclean($url) eq &symbclean($thisfn)) { return 0; }
   
       $symb=&symbclean($symb);
   
       my %bighash;
       my $okay=0;
       if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
                               &GDBM_READER,0640)) {
           my $ids=$bighash{'ids_/res/'.$thisfn};
           unless ($ids) { 
              $ids=$bighash{'ids_/'.$thisfn};
           }
           if ($ids) {
   # ------------------------------------------------------------------- Has ID(s)
       foreach (split(/\,/,$ids)) {
                  my ($mapid,$resid)=split(/\./,$_);
                  if (
     &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)
      eq $symb) { 
                     $okay=1; 
                  }
      }
           }
    untie(%bighash);
       }
       return $okay;
   }
   
   # --------------------------------------------------------------- Clean-up symb
   
   sub symbclean {
       my $symb=shift;
   
   # remove version from map
       $symb=~s/\.(\d+)\.(\w+)\_\_\_/\.$2\_\_\_/;
   
   # remove version from URL
       $symb=~s/\.(\d+)\.(\w+)$/\.$2/;
   
       return $symb;
   }
   
 # ------------------------------------------------------ Return symb list entry  # ------------------------------------------------------ Return symb list entry
   
 sub symbread {  sub symbread {
     my $thisfn=shift;      my $thisfn=shift;
     unless ($thisfn) {      unless ($thisfn) {
         if ($ENV{'request.symb'}) { return $ENV{'request.symb'}; }          if ($ENV{'request.symb'}) { return &symbclean($ENV{'request.symb'}); }
  $thisfn=$ENV{'request.filename'};   $thisfn=$ENV{'request.filename'};
     }      }
     $thisfn=declutter($thisfn);      $thisfn=declutter($thisfn);
Line 2446  sub symbread { Line 2659  sub symbread {
            }              } 
         }          }
         if ($syval) {          if ($syval) {
            return $syval.'___'.$thisfn;              return &symbclean($syval.'___'.$thisfn); 
         }          }
     }      }
     &appenv('request.ambiguous' => $thisfn);      &appenv('request.ambiguous' => $thisfn);
Line 2585  sub unescape { Line 2798  sub unescape {
 # ================================================================ Main Program  # ================================================================ Main Program
   
 sub goodbye {  sub goodbye {
      &logthis("Starting Shut down");
    &flushcourselogs();     &flushcourselogs();
    &logthis("Shutting down");     &logthis("Shutting down");
 }  }
   
 BEGIN {  BEGIN {
 # ------------------------------------------------------------ Read access.conf  # ---------------------------------- Read loncapa_apache.conf and loncapa.conf
   # (eventually access.conf will become deprecated)
     unless ($readit) {      unless ($readit) {
   
   {
       my $config=Apache::File->new("/etc/httpd/conf/loncapa_apache.conf");
   
       while (my $configline=<$config>) {
           if ($configline =~ /^[^\#]*PerlSetVar/) {
      my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
              chomp($varvalue);
              $perlvar{$varname}=$varvalue;
           }
       }
   }
   {
       my $config=Apache::File->new("/etc/httpd/conf/loncapa.conf");
   
       while (my $configline=<$config>) {
           if ($configline =~ /^[^\#]*PerlSetVar/) {
      my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
              chomp($varvalue);
              $perlvar{$varname}=$varvalue;
           }
       }
   }
 {  {
     my $config=Apache::File->new("/etc/httpd/conf/access.conf");      my $config=Apache::File->new("/etc/httpd/conf/loncapa_apache.conf");
   
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
         if ($configline =~ /PerlSetVar/) {          if ($configline =~ /^[^\#]*PerlSetVar/) {
    my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);     my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
            chomp($varvalue);             chomp($varvalue);
            $perlvar{$varname}=$varvalue;             $perlvar{$varname}=$varvalue;
Line 2847  devalidate($symb) : devalidate spreadshe Line 3085  devalidate($symb) : devalidate spreadshe
 =item *  =item *
   
 hash2str(%hash) : convert a hash into a string complete with escaping and '='  hash2str(%hash) : convert a hash into a string complete with escaping and '='
 and '&' separators  and '&' separators, supports elements that are arrayrefs and hashrefs
   
   =item *
   
   hashref2str($hashref) : convert a hashref into a string complete with
   escaping and '=' and '&' separators, supports elements that are
   arrayrefs and hashrefs
   
   =item *
   
   arrayref2str($arrayref) : convert an arrayref into a string complete
   with escaping and '&' separators, supports elements that are arrayrefs
   and hashrefs
   
   =item *
   
   str2hash($string) : convert string to hash using unescaping and
   splitting on '=' and '&', supports elements that are arrayrefs and
   hashrefs
   
 =item *  =item *
   
 str2hash($string) : convert string to hash using unescaping and splitting on  str2array($string) : convert string to hash using unescaping and
 '=' and '&'  splitting on '&', supports elements that are arrayrefs and hashrefs
   
 =item *  =item *
   
Line 3047  replicates and subscribes to the file Line 3303  replicates and subscribes to the file
 =item *  =item *
   
 filelocation($dir,$file) : returns file system location of a file based on URI;  filelocation($dir,$file) : returns file system location of a file based on URI;
 meant to be "fairly clean" absolute reference  meant to be "fairly clean" absolute reference, $dir is a directory that relative $file lookups are to looked in ($dir of /a/dir and a file of ../bob will become /a/bob)
   
 =item *  =item *
   
Removed from v.1.201  
changed lines
  Added in v.1.224

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