[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.206 and 1.218

version 1.206, 2002/04/04 20:06:20 version 1.218, 2002/05/13 09:26:29
Line 84  qw(%perlvar %hostname %homecache %hostip Line 84  qw(%perlvar %hostname %homecache %hostip
 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 627  sub subscribe { Line 627  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 716  sub flushcourselogs { Line 717  sub flushcourselogs {
     &logthis('Flushing course log buffers');      &logthis('Flushing course log buffers');
     foreach (keys %courselogs) {      foreach (keys %courselogs) {
         my $crsid=$_;          my $crsid=$_;
  &logthis(":$crsid:$coursehombuf{$crsid}");  
         if (&reply('log:'.$coursedombuf{$crsid}.':'.          if (&reply('log:'.$coursedombuf{$crsid}.':'.
           &escape($courselogs{$crsid}),            &escape($courselogs{$crsid}),
           $coursehombuf{$crsid}) eq 'ok') {            $coursehombuf{$crsid}) eq 'ok') {
Line 1139  sub store { Line 1139  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 1169  sub cstore { Line 1170  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 1204  sub restore { Line 1206  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 1877  sub modifyuser { Line 1879  sub modifyuser {
 # ----------------------------------------------------------------- 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=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};  
         } elsif (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) {   
             $unhome = $desiredhome;              $unhome = $desiredhome;
         } else {   } elsif($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $udom) {
       $unhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};
           } 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 1907  sub modifyuser { Line 1909  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 1925  sub modifyuser { Line 1927  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 1942  sub modifyuser { Line 1945  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 2192  sub courseresdata { Line 2196  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 2208  sub EXT { Line 2223  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 2229  sub EXT { Line 2253  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 2249  sub EXT { Line 2273  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') {
Line 2388  sub metadata { Line 2406  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 2477  sub metadata { Line 2495  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 2515  sub symblist { Line 2533  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 2579  sub symbread { Line 2648  sub symbread {
            }              } 
         }          }
         if ($syval) {          if ($syval) {
            return $syval.'___'.$thisfn;              return &symbclean($syval.'___'.$thisfn); 
         }          }
     }      }
     &appenv('request.ambiguous' => $thisfn);      &appenv('request.ambiguous' => $thisfn);
Line 2724  sub goodbye { Line 2793  sub goodbye {
 }  }
   
 BEGIN {  BEGIN {
 # ------------------------------------------------------------ Read access.conf  # ------------------------------------------- Read access.conf and loncapa.conf
   # (eventually access.conf will become deprecated)
     unless ($readit) {      unless ($readit) {
   
 {  {
     my $config=Apache::File->new("/etc/httpd/conf/access.conf");      my $config=Apache::File->new("/etc/httpd/conf/access.conf");
   
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
         if ($configline =~ /PerlSetVar/) {          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);     my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
            chomp($varvalue);             chomp($varvalue);
            $perlvar{$varname}=$varvalue;             $perlvar{$varname}=$varvalue;
Removed from v.1.206  
changed lines
  Added in v.1.218

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