[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.85 and 1.103

version 1.85, 2000/12/29 22:40:33 version 1.103, 2001/02/27 20:44:18
Line 13 Line 13
 #                      1: user needs to choose course  #                      1: user needs to choose course
 #                      2: browse allowed  #                      2: browse allowed
 # definerole(rolename,sys,dom,cou) : define a custom role rolename  # definerole(rolename,sys,dom,cou) : define a custom role rolename
 #                      set priviledges in format of lonTabs/roles.tab for  #                      set privileges in format of lonTabs/roles.tab for
 #                      system, domain and course level,   #                      system, domain and course level, 
 # assignrole(udom,uname,url,role,end,start) : give a role to a user for the  # assignrole(udom,uname,url,role,end,start) : give a role to a user for the
 #                      level given by url. Optional start and end dates  #                      level given by url. Optional start and end dates
Line 82 Line 82
 # 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,12/12,12/13,12/14,12/28,12/29 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
   # 09/01 Guy Albertelli
   # 09/01,10/01,11/01 Gerd Kortemeyer
   # 02/27/01 Scott Harrison
   
 package Apache::lonnet;  package Apache::lonnet;
   
Line 95  use IO::Socket; Line 100  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 177  sub reconlonc { Line 183  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 235  sub appenv { Line 246  sub appenv {
             $ENV{$_}=$newenv{$_};              $ENV{$_}=$newenv{$_};
         }          }
     } keys %newenv;      } keys %newenv;
   
       my $lockfh;
       unless ($lockfh=Apache::File->new("$ENV{'user.environment'}")) {
          return 'error: '.$!;
       }
       unless (flock($lockfh,LOCK_EX)) {
            &logthis("<font color=blue>WARNING: ".
                     'Could not obtain exclusive lock in appenv: '.$!);
            $lockfh->close();
            return 'error: '.$!;
       }
   
     my @oldenv;      my @oldenv;
     {      {
      my $fh;       my $fh;
      unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {       unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {
  return 'error';   return 'error: '.$!;
      }       }
      @oldenv=<$fh>;       @oldenv=<$fh>;
        $fh->close();
     }      }
     for (my $i=0; $i<=$#oldenv; $i++) {      for (my $i=0; $i<=$#oldenv; $i++) {
         chomp($oldenv[$i]);          chomp($oldenv[$i]);
Line 261  sub appenv { Line 285  sub appenv {
      foreach $newname (keys %newenv) {       foreach $newname (keys %newenv) {
  print $fh "$newname=$newenv{$newname}\n";   print $fh "$newname=$newenv{$newname}\n";
      }       }
        $fh->close();
     }      }
   
       $lockfh->close();
     return 'ok';      return 'ok';
 }  }
 # ----------------------------------------------------- Delete from Environment  # ----------------------------------------------------- Delete from Environment
Line 280  sub delenv { Line 307  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 653  sub coursedescription { Line 694  sub coursedescription {
     if ($chome ne 'no_host') {      if ($chome ne 'no_host') {
        my $rep=reply("dump:$cdomain:$cnum:environment",$chome);         my $rep=reply("dump:$cdomain:$cnum:environment",$chome);
        if ($rep ne 'con_lost') {         if ($rep ne 'con_lost') {
            my $normalid=$courseid;             my $normalid=$cdomain.'_'.$cnum;
            $normalid=~s/\//\_/g;  
            my %envhash=();             my %envhash=();
            my %returnhash=('home'   => $chome,              my %returnhash=('home'   => $chome, 
                            'domain' => $cdomain,                             'domain' => $cdomain,
Line 680  sub coursedescription { Line 720  sub coursedescription {
     return ();      return ();
 }  }
   
 # -------------------------------------------------------- Get user priviledges  # -------------------------------------------------------- Get user privileges
   
 sub rolesinit {  sub rolesinit {
     my ($domain,$username,$authhost)=@_;      my ($domain,$username,$authhost)=@_;
Line 754  sub rolesinit { Line 794  sub rolesinit {
             %thesepriv=();              %thesepriv=();
             map {              map {
                 if ($_ ne '') {                  if ($_ ne '') {
     my ($priviledge,$restrictions)=split(/&/,$_);      my ($privilege,$restrictions)=split(/&/,$_);
                     if ($restrictions eq '') {                      if ($restrictions eq '') {
  $thesepriv{$priviledge}='F';   $thesepriv{$privilege}='F';
                     } else {                      } else {
                         if ($thesepriv{$priviledge} ne 'F') {                          if ($thesepriv{$privilege} ne 'F') {
     $thesepriv{$priviledge}.=$restrictions;      $thesepriv{$privilege}.=$restrictions;
                         }                          }
                     }                      }
                 }                  }
Line 869  sub eget { Line 909  sub eget {
    return %returnhash;     return %returnhash;
 }  }
   
 # ------------------------------------------------- Check for a user priviledge  # ------------------------------------------------- Check for a user privilege
   
 sub allowed {  sub allowed {
     my ($priv,$uri)=@_;      my ($priv,$uri)=@_;
Line 920  sub allowed { Line 960  sub allowed {
  return $thisallowed;   return $thisallowed;
     }      }
 #  #
 # Gathered so far: system, domain and course wide priviledges  # Gathered so far: system, domain and course wide privileges
 #  #
 # Course: See if uri or referer is an individual resource that is part of   # Course: See if uri or referer is an individual resource that is part of 
 # the course  # the course
Line 971  sub allowed { Line 1011  sub allowed {
    }     }
   
 #  #
 # Gathered now: all priviledges that could apply, and condition number  # Gathered now: all privileges that could apply, and condition number
 #   # 
 #  #
 # Full or no access?  # Full or no access?
Line 1003  sub allowed { Line 1043  sub allowed {
            if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {             if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {
                my $courseid=$2;                 my $courseid=$2;
                my $roleid=$1.'.'.$2;                 my $roleid=$1.'.'.$2;
                  $courseid=~s/^\///;
                my $expiretime=600;                 my $expiretime=600;
                if ($ENV{'request.role'} eq $roleid) {                 if ($ENV{'request.role'} eq $roleid) {
   $expiretime=120;    $expiretime=120;
Line 1576  sub EXT { Line 1617  sub EXT {
        my $courselevelm=         my $courselevelm=
             $ENV{'request.course.id'}.'.'.$mapparm;              $ENV{'request.course.id'}.'.'.$mapparm;
   
   
 # ----------------------------------------------------------- first, check user  # ----------------------------------------------------------- first, check user
       my %resourcedata=get('resourcedata',        my %resourcedata=get('resourcedata',
                            ($courselevelr,$courselevelm,$courselevel));                             ($courselevelr,$courselevelm,$courselevel));
       if ($resourcedata{$courselevelr}!~/^error\:/) {        if (($resourcedata{$courselevelr}!~/^error\:/) &&
             ($resourcedata{$courselevelr}!~/^con_lost/)) {
   
        if ($resourcedata{$courselevelr}) {          if ($resourcedata{$courselevelr}) { 
           return $resourcedata{$courselevelr}; }            return $resourcedata{$courselevelr}; }
Line 1588  sub EXT { Line 1629  sub EXT {
           return $resourcedata{$courselevelm}; }            return $resourcedata{$courselevelm}; }
        if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; }         if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; }
   
         } else {
     if ($resourcedata{$courselevelr}!~/No such file/) {
       &logthis("<font color=blue>WARNING:".
      " Trying to get resource data for ".$ENV{'user.name'}." at "
                      .$ENV{'user.domain'}.": ".$resourcedata{$courselevelr}.
                    "</font>");
     }
       }        }
   
 # -------------------------------------------------------- second, check course  # -------------------------------------------------------- second, check course
         my $section='';  
         if ($ENV{'request.course.sec'}) {  
     $section='_'.$ENV{'request.course.sec'};  
         }  
         my $reply=&reply('get:'.          my $reply=&reply('get:'.
               $ENV{'course.'.$ENV{'request.course.id'}.$section.'.domain'}.':'.                $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'.
               $ENV{'course.'.$ENV{'request.course.id'}.$section.'.num'}.                $ENV{'course.'.$ENV{'request.course.id'}.'.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'}.'.home'});
       if ($reply!~/^error\:/) {        if ($reply!~/^error\:/) {
   map {    map {
       if ($_) { return &unescape($_); }        if ($_) { return &unescape($_); }
           } split(/\&/,$reply);            } split(/\&/,$reply);
       }        }
         if (($reply=~/^con_lost/) || ($reply=~/^error\:/)) {
     &logthis("<font color=blue>WARNING:".
                   " Getting ".$reply." asking for ".$varname." for ".
                   $ENV{'course.'.$ENV{'request.course.id'}.'.num'}.
                   ' at '.
                   $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.
                   ' from '.
                   $ENV{'course.'.$ENV{'request.course.id'}.'.home'}.
                    "</font>");
         }
 # ------------------------------------------------------ third, check map parms  # ------------------------------------------------------ third, check map parms
        my %parmhash=();         my %parmhash=();
        my $thisparm='';                my $thisparm='';       
Line 1789  sub numval { Line 1844  sub numval {
 sub rndseed {  sub rndseed {
     my $symb;      my $symb;
     unless ($symb=&symbread()) { return time; }      unless ($symb=&symbread()) { return time; }
     my $symbchck=unpack("%32C*",$symb);      { 
     my $symbseed=numval($symb)%$symbchck;        use integer;
     my $namechck=unpack("%32C*",$ENV{'user.name'});        my $symbchck=unpack("%32C*",$symb) << 27;
     my $nameseed=numval($ENV{'user.name'})%$namechck;        my $symbseed=numval($symb) << 22;
     return int( $symbseed        my $namechck=unpack("%32C*",$ENV{'user.name'}) << 17;
        .$nameseed        my $nameseed=numval($ENV{'user.name'}) << 12;
                .unpack("%32C*",$ENV{'user.domain'})        my $domainseed=unpack("%32C*",$ENV{'user.domain'}) << 7;
                .unpack("%32C*",$ENV{'request.course.id'})        my $courseseed=unpack("%32C*",$ENV{'request.course.id'});
                .$namechck        my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;
                .$symbchck);        #uncommenting these lines can break things!
         #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
         #&Apache::lonxml::debug("rndseed :$num:$symb");
         return $num;
       }
 }  }
   
 sub ireceipt {  sub ireceipt {
Removed from v.1.85  
changed lines
  Added in v.1.103

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