[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.75 and 1.91

version 1.75, 2000/12/02 12:41:48 version 1.91, 2001/01/09 22:27:07
Line 45 Line 45
 # EXT(name)          : value of a variable  # EXT(name)          : value of a variable
 # symblist(map,hash) : Updates symbolic storage links  # symblist(map,hash) : Updates symbolic storage links
 # symbread([filename]) : returns the data handle (filename optional)  # symbread([filename]) : returns the data handle (filename optional)
 # rndseed()          : returns a random seed    # rndseed()          : returns a random seed 
   # receipt()          : returns a receipt to be given out to users 
 # getfile(filename)  : returns the contents of filename, or a -1 if it can't  # getfile(filename)  : returns the contents of filename, or a -1 if it can't
 #                      be found, replicates and subscribes to the file  #                      be found, replicates and subscribes to the file
 # filelocation(dir,file) : returns a farily clean absolute reference to file   # filelocation(dir,file) : returns a farily clean absolute reference to file 
Line 80 Line 81
 # 10/06,10/09,10/10,10/11,10/14,10/20,10/23,10/25,10/26,10/27,10/28,10/29,   # 10/06,10/09,10/10,10/11,10/14,10/20,10/23,10/25,10/26,10/27,10/28,10/29, 
 # 10/30,10/31,  # 10/30,10/31,
 # 11/2,11/14,11/15,11/16,11/20,11/21,11/22,11/25,11/27,  # 11/2,11/14,11/15,11/16,11/20,11/21,11/22,11/25,11/27,
 # 12/02 Gerd Kortemeyer  # 12/02,12/12,12/13,12/14,12/28,12/29 Gerd Kortemeyer
   # 05/01/01 Guy Albertelli
   # 05/01,06/01,09/01 Gerd Kortemeyer
   
 package Apache::lonnet;  package Apache::lonnet;
   
Line 94  use IO::Socket; Line 97  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::TokeParser;
   use Fcntl qw(:flock);
   
 # --------------------------------------------------------------------- Logging  # --------------------------------------------------------------------- Logging
   
Line 176  sub reconlonc { Line 180  sub reconlonc {
   
 sub critical {  sub critical {
     my ($cmd,$server)=@_;      my ($cmd,$server)=@_;
       unless ($hostname{$server}) {
           &logthis("<font color=blue>WARNING:".
                  " Critical message to unknown server ($server)</font>");
           return 'no_such_host';
       }
     my $answer=reply($cmd,$server);      my $answer=reply($cmd,$server);
     if ($answer eq 'con_lost') {      if ($answer eq 'con_lost') {
         my $pingreply=reply('ping',$server);          my $pingreply=reply('ping',$server);
Line 225  sub critical { Line 234  sub critical {
   
 sub appenv {  sub appenv {
     my %newenv=@_;      my %newenv=@_;
       my ($in,$out);
     map {      map {
  if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) {   if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) {
             &logthis("<font color=blue>WARNING: ".              &logthis("<font color=blue>WARNING: ".
Line 240  sub appenv { Line 250  sub appenv {
      unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {       unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {
  return 'error';   return 'error';
      }       }
        unless (flock($fh,LOCK_SH)) {
            &logthis("<font color=blue>WARNING: ".
                     'Could not obtain shared lock in appenv: '.$!);
            $fh->close();
            return 'error: '.$!;
        }
        &logthis("<font color=green>appenv LOCK_SH gotten");
      @oldenv=<$fh>;       @oldenv=<$fh>;
        $in=$#oldenv+1;
        &logthis("<font color=green>appenv LOCK_SH to be closed");
        $fh->close();
     }      }
       &logthis("<font color=green>Number of elements read appenv: ".$in."from".join(" ",caller));
     for (my $i=0; $i<=$#oldenv; $i++) {      for (my $i=0; $i<=$#oldenv; $i++) {
         chomp($oldenv[$i]);          chomp($oldenv[$i]);
         if ($oldenv[$i] ne '') {          if ($oldenv[$i] ne '') {
Line 257  sub appenv { Line 278  sub appenv {
  return 'error';   return 'error';
      }       }
      my $newname;       my $newname;
      foreach $newname (keys %newenv) {       unless (flock($fh,LOCK_EX)) {
            &logthis("<font color=blue>WARNING: ".
                     'Could not obtain exclusive lock in appenv: '.$!);
            $fh->close();
            return 'error: '.$!;
        }
        &logthis("<font color=green>appenv LOCK_EX gotten");
        $out=0;
        foreach $newname (sort keys %newenv) {
  print $fh "$newname=$newenv{$newname}\n";   print $fh "$newname=$newenv{$newname}\n";
    $out++;
      }       }
        &logthis("<font color=green>appenv LOCK_EX to be closed");
        $fh->close();
     }      }
       &logthis("<font color=green>Number of elements read appenv: ".$in." number out:".$out."from".join(" ",caller));
     return 'ok';      return 'ok';
 }  }
 # ----------------------------------------------------- Delete from Environment  # ----------------------------------------------------- Delete from Environment
Line 279  sub delenv { Line 312  sub delenv {
      unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {       unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {
  return 'error';   return 'error';
      }       }
        unless (flock($fh,LOCK_SH)) {
            &logthis("<font color=blue>WARNING: ".
                     'Could not obtain shared lock in delenv: '.$!);
            $fh->close();
            return 'error: '.$!;
        }
      @oldenv=<$fh>;       @oldenv=<$fh>;
        $fh->close();
     }      }
     {      {
      my $fh;       my $fh;
      unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) {       unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) {
  return 'error';   return 'error';
      }       }
        unless (flock($fh,LOCK_EX)) {
            &logthis("<font color=blue>WARNING: ".
                     'Could not obtain exclusive lock in delenv: '.$!);
            $fh->close();
            return 'error: '.$!;
        }
      map {       map {
  unless ($_=~/^$delthis/) { print $fh $_; }   unless ($_=~/^$delthis/) { print $fh $_; }
      } @oldenv;       } @oldenv;
        $fh->close();
     }      }
     return 'ok';      return 'ok';
 }  }
Line 383  sub idget { Line 430  sub idget {
           $idlist=~tr/A-Z/a-z/;             $idlist=~tr/A-Z/a-z/; 
   my $reply=&reply("idget:$udom:".$idlist,$tryserver);    my $reply=&reply("idget:$udom:".$idlist,$tryserver);
           my @answer=();            my @answer=();
           if ($reply ne 'con_lost') {            if (($reply ne 'con_lost') && ($reply!~/^error\:/)) {
       @answer=split(/\&/,$reply);        @answer=split(/\&/,$reply);
           }                    ;            }                    ;
           my $i;            my $i;
Line 900  sub allowed { Line 947  sub allowed {
 # Course: uri itself is a course  # Course: uri itself is a course
     my $courseuri=$uri;      my $courseuri=$uri;
     $courseuri=~s/\_(\d)/\/$1/;      $courseuri=~s/\_(\d)/\/$1/;
     if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseuri}      $courseuri=~s/^([^\/])/\/$1/;
   
       if ($ENV{'user.priv.'.$ENV{'request.role'}.'.'.$courseuri}
        =~/$priv\&([^\:]*)/) {         =~/$priv\&([^\:]*)/) {
        $thisallowed.=$1;         $thisallowed.=$1;
     }      }
Line 942  sub allowed { Line 991  sub allowed {
                $checkreferer=0;                 $checkreferer=0;
            }             }
        }         }
          
        if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) {         if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) {
   my $refuri=$ENV{'HTTP_REFERER'};    my $refuri=$ENV{'HTTP_REFERER'};
           $refuri=~s/^http\:\/\/$ENV{'request.host'}//i;            $refuri=~s/^http\:\/\/$ENV{'request.host'}//i;
Line 1163  sub filedescription { Line 1212  sub filedescription {
 sub assignrole {  sub assignrole {
     my ($udom,$uname,$url,$role,$end,$start)=@_;      my ($udom,$uname,$url,$role,$end,$start)=@_;
     my $mrole;      my $mrole;
     $url=declutter($url);  
     if ($role =~ /^cr\//) {      if ($role =~ /^cr\//) {
         unless ($url=~/\.course$/) { return 'invalid'; }   unless (&allowed('ccr',$url)) { return 'refused'; }
  unless (allowed('ccr',$url)) { return 'refused'; }  
         $mrole='cr';          $mrole='cr';
     } else {      } else {
         unless (($url=~/\.course$/) || ($url=~/\/$/)) { return 'invalid'; }          my $cwosec=$url;
         unless (allowed('c'+$role)) { return 'refused'; }          $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
           unless (&allowed('c'.$role,$cwosec)) { return 'refused'; }
         $mrole=$role;          $mrole=$role;
     }      }
     my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".      my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".
                 "$udom:$uname:$url".'_'."$mrole=$role";                  "$udom:$uname:$url".'_'."$mrole=$role";
     if ($end) { $command.='_$end'; }      if ($end) { $command.='_'.$end; }
     if ($start) {      if ($start) {
  if ($end) {    if ($end) { 
            $command.='_$start';              $command.='_'.$start; 
         } else {          } else {
            $command.='_0_$start';             $command.='_0_'.$start;
         }          }
     }      }
     return &reply($command,&homeserver($uname,$udom));      return &reply($command,&homeserver($uname,$udom));
 }  }
   
   # --------------------------------------------------------------- Modify a user
   
   
   sub modifyuser {
       my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene)=@_;
       &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
                $umode.', '.$first.', '.$middle.', '.
        $last.', '.$gene.' by '.
                $ENV{'user.name'}.' at '.$ENV{'user.domain'});  
       my $uhome=&homeserver($uname,$udom);
   # ----------------------------------------------------------------- Create User
       if (($uhome eq 'no_host') && ($umode) && ($upass)) {
           my $unhome='';
    if ($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $udom) {
       $unhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};
           } else {
               my $tryserver;
               my $loadm=10000000;
               foreach $tryserver (keys %libserv) {
          if ($hostdom{$tryserver} eq $udom) {
                     my $answer=reply('load',$tryserver);
                     if (($answer=~/\d+/) && ($answer<$loadm)) {
         $loadm=$answer;
                         $unhome=$tryserver;
                     }
          }
       }
           }
           if (($unhome eq '') || ($unhome eq 'no_host')) {
       return 'error: find home';
           }
           my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':'.$umode.':'.
                            &escape($upass),$unhome);
    unless ($reply eq 'ok') {
               return 'error: '.$reply;
           }   
           $uhome=&homeserver($uname,$udom);
           if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) {
       return 'error: verify home';
           }
       }
   # ---------------------------------------------------------------------- Add ID
       if ($uid) {
          $uid=~tr/A-Z/a-z/;
          my %uidhash=&idrget($udom,$uname);
          if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/)) {
     unless ($uid eq $uidhash{$uname}) {
         return 'error: mismatch '.$uidhash{$uname}.' versus '.$uid;
             }
          } else {
     &idput($udom,($uname => $uid));
          }
       }
   # -------------------------------------------------------------- Add names, etc
       my $names=&reply('get:'.$udom.':'.$uname.
                        ':environment:firstname&middlename&lastname&generation',
                        $uhome);
       my ($efirst,$emiddle,$elast,$egene)=split(/\&/,$names);
       if ($first)  { $efirst  = &escape($first); }
       if ($middle) { $emiddle = &escape($middle); }
       if ($last)   { $elast   = &escape($last); }
       if ($gene)   { $egene   = &escape($gene); }
       my $reply=&reply('put:'.$udom.':'.$uname.
              ':environment:firstname='.$efirst.
                         '&middlename='.$emiddle.
                           '&lastname='.$elast.
                         '&generation='.$egene,$uhome);
       if ($reply ne 'ok') {
    return 'error: '.$reply;
       }
       &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
                $umode.', '.$first.', '.$middle.', '.
        $last.', '.$gene.' by '.
                $ENV{'user.name'}.' at '.$ENV{'user.domain'});
       return 'ok'; 
   }
   
   # -------------------------------------------------------------- Modify student
   
   sub modifystudent {
       my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
           $end,$start)=@_;
       my $cid='';
       unless ($cid=$ENV{'request.course.id'}) {
    return 'not_in_class';
       }
   # --------------------------------------------------------------- Make the user
       my $reply=&modifyuser
    ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene);
       unless ($reply eq 'ok') { return $reply; }
       my $uhome=&homeserver($uname,$udom);
       if (($uhome eq '') || ($uhome eq 'no_host')) { 
    return 'error: no such user';
       }
   # -------------------------------------------------- Add student to course list
       my $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'.
                 $ENV{'course.'.$cid.'.num'}.':classlist:'.
                         &escape($uname.':'.$udom).'='.
                         &escape($end.':'.$start),
                 $ENV{'course.'.$cid.'.home'});
       unless (($reply eq 'ok') || ($reply eq 'delayed')) {
    return 'error: '.$reply;
       }
   # ---------------------------------------------------- Add student role to user
       my $uurl='/'.$cid;
       $uurl=~s/\_/\//g;
       if ($usec) {
    $uurl.='/'.$usec;
       }
       return &assignrole($udom,$uname,$uurl,'st',$end,$start);
   }
   
   # ------------------------------------------------- Write to course preferences
   
   sub writecoursepref {
       my ($courseid,%prefs)=@_;
       $courseid=~s/^\///;
       $courseid=~s/\_/\//g;
       my ($cdomain,$cnum)=split(/\//,$courseid);
       my $chome=homeserver($cnum,$cdomain);
       if (($chome eq '') || ($chome eq 'no_host')) { 
    return 'error: no such course';
       }
       my $cstring='';
       map {
    $cstring.=escape($_).'='.escape($prefs{$_}).'&';
       } keys %prefs;
       $cstring=~s/\&$//;
       return reply('put:'.$cdomain.':'.$cnum.':environment:'.$cstring,$chome);
   }
   
   # ---------------------------------------------------------- Make/modify course
   
   sub createcourse {
       my ($udom,$description,$url)=@_;
       $url=&declutter($url);
       my $cid='';
       unless (&allowed('ccc',$ENV{'user.domain'})) {
           return 'refused';
       }
       unless ($udom eq $ENV{'user.domain'}) {
           return 'refused';
       }
   # ------------------------------------------------------------------- Create ID
      my $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).
          unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
   # ----------------------------------------------- Make sure that does not exist
      my $uhome=&homeserver($uname,$udom);
      unless (($uhome eq '') || ($uhome eq 'no_host')) {
          $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).
           unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
          $uhome=&homeserver($uname,$udom);       
          unless (($uhome eq '') || ($uhome eq 'no_host')) {
              return 'error: unable to generate unique course-ID';
          } 
      }
   # ------------------------------------------------------------- Make the course
       my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',
                         $ENV{'user.home'});
       unless ($reply eq 'ok') { return 'error: '.$reply; }
       my $uhome=&homeserver($uname,$udom);
       if (($uhome eq '') || ($uhome eq 'no_host')) { 
    return 'error: no such course';
       }
       &writecoursepref($udom.'_'.$uname,
                        ('description' => $description,
                         'url'         => $url));
       return '/'.$udom.'/'.$uname;
   }
   
 # ---------------------------------------------------------- Assign Custom Role  # ---------------------------------------------------------- Assign Custom Role
   
 sub assigncustomrole {  sub assigncustomrole {
Line 1425  sub EXT { Line 1643  sub EXT {
         my $reply=&reply('get:'.          my $reply=&reply('get:'.
               $ENV{'course.'.$ENV{'request.course.id'}.$section.'.domain'}.':'.                $ENV{'course.'.$ENV{'request.course.id'}.$section.'.domain'}.':'.
               $ENV{'course.'.$ENV{'request.course.id'}.$section.'.num'}.                $ENV{'course.'.$ENV{'request.course.id'}.$section.'.num'}.
               ':resourcedata:'.        ':resourcedata:'.
  escape($seclevelr).':'.escape($seclevelm).':'.escape($seclevel).':'.     &escape($seclevelr).'&'.&escape($seclevelm).'&'.&escape($seclevel).'&'.
  escape($courselevelr).':'.escape($courselevelm).':'.escape($courselevel),     &escape($courselevelr).'&'.&escape($courselevelm).'&'.&escape($courselevel),
    $ENV{'course.'.$ENV{'request.course.id'}.$section.'.home'});     $ENV{'course.'.$ENV{'request.course.id'}.$section.'.home'});
       if ($reply!~/^error\:/) {        if ($reply!~/^error\:/) {
         map {    map {
            my ($name,$value)=split(/\=/,$_);        if ($_) { return &unescape($_); }
            $resourcedata{unescape($name)}=unescape($value);              } split(/\&/,$reply);
         } split(/\&/,$reply);  
   
        if ($resourcedata{$seclevelr}) { return $resourcedata{$seclevelr}; }  
        if ($resourcedata{$seclevelm}) { return $resourcedata{$seclevelm}; }    
        if ($resourcedata{$seclevel}) { return $resourcedata{$seclevel}; }  
   
        if ($resourcedata{$courselevelr}) {   
           return $resourcedata{$courselevelr}; }  
        if ($resourcedata{$courselevelm}) {   
           return $resourcedata{$courselevelm}; }  
        if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; }  
   
       }        }
   
 # ------------------------------------------------------ third, check map parms  # ------------------------------------------------------ third, check map parms
Line 1460  sub EXT { Line 1666  sub EXT {
             
 # --------------------------------------------- last, look in resource metadata  # --------------------------------------------- last, look in resource metadata
   
         $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'},
                                            'parameter_'.$spacequalifierrest);
         if ($metadata) { return $metadata; }
   
 # ---------------------------------------------------- Any other user namespace  # ---------------------------------------------------- Any other user namespace
     } elsif ($realm eq 'environment') {      } elsif ($realm eq 'environment') {
Line 1480  sub EXT { Line 1690  sub EXT {
   
 sub metadata {  sub metadata {
     my ($uri,$what)=@_;      my ($uri,$what)=@_;
   
     $uri=&declutter($uri);      $uri=&declutter($uri);
     my $filename=$uri;      my $filename=$uri;
     $uri=~s/\.meta$//;      $uri=~s/\.meta$//;
Line 1506  sub metadata { Line 1717  sub metadata {
               map {                map {
   $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};    $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};
               } @{$token->[3]};                } @{$token->[3]};
               $metacache{$uri.':'.$unikey}=$parser->get_text('/'.$entry);                unless (
                    $metacache{$uri.':'.$unikey}=$parser->get_text('/'.$entry)
         ) { $metacache{$uri.':'.$unikey}=
         $metacache{$uri.':'.$unikey.'.default'};
         }
           }            }
        }         }
     }      }
Line 1632  sub rndseed { Line 1847  sub rndseed {
                .$symbchck);                 .$symbchck);
 }  }
   
   sub ireceipt {
       my ($funame,$fudom,$fucourseid,$fusymb)=@_;
       my $cuname=unpack("%32C*",$funame);
       my $cudom=unpack("%32C*",$fudom);
       my $cucourseid=unpack("%32C*",$fucourseid);
       my $cusymb=unpack("%32C*",$fusymb);
       my $cunique=unpack("%32C*",$perlvar{'lonReceipt'});
       return unpack("%32C*",$perlvar{'lonHostID'}).'-'.
              ($cunique%$cuname+
               $cunique%$cudom+
               $cusymb%$cuname+
               $cusymb%$cudom+
               $cucourseid%$cuname+
               $cucourseid%$cudom);
   }
   
   sub receipt {
       return &ireceipt($ENV{'user.name'},$ENV{'user.domain'},
                        $ENV{'request.course.id'},&symbread());
   }
     
 # ------------------------------------------------------------ Serves up a file  # ------------------------------------------------------------ Serves up a file
 # returns either the contents of the file or a -1  # returns either the contents of the file or a -1
 sub getfile {  sub getfile {
Removed from v.1.75  
changed lines
  Added in v.1.91

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