[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.95 and 1.120

version 1.95, 2001/01/11 10:43:09 version 1.120, 2001/04/02 16:56:22
Line 3 Line 3
 #  #
 # Functions for use by content handlers:  # Functions for use by content handlers:
 #  #
   # metadata_query(sql-query-string,custom-metadata-regex) : 
   #                                    returns file handle of where sql and
   #                                    regex results will be stored for query
 # plaintext(short)   : plain text explanation of short term  # plaintext(short)   : plain text explanation of short term
 # fileembstyle(ext)  : embed style in page for file extension  # fileembstyle(ext)  : embed style in page for file extension
 # filedescription(ext) : descriptor text for file extension  # filedescription(ext) : descriptor text for file extension
Line 13 Line 16
 #                      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 86 Line 89
 # 05/01,06/01,09/01 Gerd Kortemeyer  # 05/01,06/01,09/01 Gerd Kortemeyer
 # 09/01 Guy Albertelli  # 09/01 Guy Albertelli
 # 09/01,10/01,11/01 Gerd Kortemeyer  # 09/01,10/01,11/01 Gerd Kortemeyer
   # 02/27/01 Scott Harrison
   # 3/2 Gerd Kortemeyer
   # 3/15,3/19 Scott Harrison
   # 3/19,3/20 Gerd Kortemeyer
   # 3/22,3/27 Scott Harrison
   
 package Apache::lonnet;  package Apache::lonnet;
   
Line 248  sub appenv { Line 256  sub appenv {
   
     my $lockfh;      my $lockfh;
     unless ($lockfh=Apache::File->new("$ENV{'user.environment'}")) {      unless ($lockfh=Apache::File->new("$ENV{'user.environment'}")) {
        return 'error';         return 'error: '.$!;
     }      }
     unless (flock($lockfh,LOCK_EX)) {      unless (flock($lockfh,LOCK_EX)) {
          &logthis("<font color=blue>WARNING: ".           &logthis("<font color=blue>WARNING: ".
Line 261  sub appenv { Line 269  sub appenv {
     {      {
      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();       $fh->close();
Line 622  sub log { Line 630  sub log {
     return critical("log:$dom:$nam:$what",$hom);      return critical("log:$dom:$nam:$what",$hom);
 }  }
   
   # --------------------------------------------- Set Expire Date for Spreadsheet
   
   sub expirespread {
       my ($uname,$udom,$stype,$usymb)=@_;
       my $cid=$ENV{'request.course.id'}; 
       if ($cid) {
          my $now=time;
          my $key=$uname.':'.$udom.':'.$stype.':'.$usymb;
          return &reply('put:'.$ENV{'course.'.$cid.'.domain'}.':'.
                               $ENV{'course.'.$cid.'.num'}.
               ':nohist_expirationdates:'.
                               &escape($key).'='.$now,
                               $ENV{'course.'.$cid.'.home'})
       }
       return 'ok';
   }
   
   # ----------------------------------------------------- Devalidate Spreadsheets
   
   sub devalidate {
       my $symb=shift;
       my $cid=$ENV{'request.course.id'}; 
       if ($cid) {
    my $key=$ENV{'user.name'}.':'.$ENV{'user.domain'}.':';
           my $status=
             &reply('del:'.$ENV{'course.'.$cid.'.domain'}.':'.
                           $ENV{'course.'.$cid.'.num'}.
                   ':nohist_calculatedsheets:'.
                           &escape($key.'studentcalc:'),
                           $ENV{'course.'.$cid.'.home'})
             .' '.
             &reply('del:'.$ENV{'user.domain'}.':'.
                           $ENV{'user.name'}.
           ':nohist_calculatedsheets_'.$cid.':'.
                           &escape($key.'assesscalc:'.$symb),
                           $ENV{'user.home'});
           unless ($status eq 'ok ok') {
              &logthis('Could not devalidate spreadsheet '.
                       $ENV{'user.name'}.' at '.$ENV{'user.domain'}.' for '.
       $symb.': '.$status);
           } 
       }
   }
   
 # ----------------------------------------------------------------------- Store  # ----------------------------------------------------------------------- Store
   
 sub store {  sub store {
     my %storehash=@_;      my %storehash=@_;
     my $symb;      my $symb;
     unless ($symb=escape(&symbread())) { return ''; }      unless ($symb=&symbread()) { return ''; }
   
       &devalidate($symb);
   
       $symb=escape($symb);
     my $namespace;      my $namespace;
     unless ($namespace=$ENV{'request.course.id'}) { return ''; }      unless ($namespace=$ENV{'request.course.id'}) { return ''; }
     my $namevalue='';      my $namevalue='';
Line 645  sub store { Line 701  sub store {
 sub cstore {  sub cstore {
     my %storehash=@_;      my %storehash=@_;
     my $symb;      my $symb;
     unless ($symb=escape(&symbread())) { return ''; }      unless ($symb=&symbread()) { return ''; }
   
       &devalidate($symb);
   
       $symb=escape($symb);
     my $namespace;      my $namespace;
     unless ($namespace=$ENV{'request.course.id'}) { return ''; }      unless ($namespace=$ENV{'request.course.id'}) { return ''; }
     my $namevalue='';      my $namevalue='';
Line 693  sub coursedescription { Line 753  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 720  sub coursedescription { Line 779  sub coursedescription {
     return ();      return ();
 }  }
   
 # -------------------------------------------------------- Get user priviledges  # -------------------------------------------------------- Get user privileges
   
 sub rolesinit {  sub rolesinit {
     my ($domain,$username,$authhost)=@_;      my ($domain,$username,$authhost)=@_;
Line 794  sub rolesinit { Line 853  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 909  sub eget { Line 968  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 960  sub allowed { Line 1019  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 1011  sub allowed { Line 1070  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 1181  sub definerole { Line 1240  sub definerole {
   }    }
 }  }
   
   # ---------------- Make a metadata query against the network of library servers
   
   sub metadata_query {
       my ($query,$custom,$customshow)=@_;
       # need to put in a library server loop here and return a hash
       my %rhash;
   #    for my $server (keys %libserv) {
       for my $server ('msul3') {
    unless ($custom or $customshow) {
       my $reply=&reply("querysend:".&escape($query),$server);
       $rhash{$server}=$reply;
    }
    else {
       my $reply=&reply("querysend:".&escape($query).':'.
        &escape($custom).':'.&escape($customshow),
        $server);
       $rhash{$server}=$reply;
    }
       }
       return \%rhash;
   }
   
 # ------------------------------------------------------------------ Plain Text  # ------------------------------------------------------------------ Plain Text
   
 sub plaintext {  sub plaintext {
Line 1208  sub assignrole { Line 1289  sub assignrole {
     my ($udom,$uname,$url,$role,$end,$start)=@_;      my ($udom,$uname,$url,$role,$end,$start)=@_;
     my $mrole;      my $mrole;
     if ($role =~ /^cr\//) {      if ($role =~ /^cr\//) {
  unless (&allowed('ccr',$url)) { return 'refused'; }   unless (&allowed('ccr',$url)) {
              &logthis('Refused custom assignrole: '.
                $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
       $ENV{'user.name'}.' at '.$ENV{'user.domain'});
              return 'refused'; 
           }
         $mrole='cr';          $mrole='cr';
     } else {      } else {
         my $cwosec=$url;          my $cwosec=$url;
         $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;          $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
         unless (&allowed('c'.$role,$cwosec)) { return 'refused'; }          unless (&allowed('c'.$role,$cwosec)) { 
              &logthis('Refused assignrole: '.
                $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
       $ENV{'user.name'}.' at '.$ENV{'user.domain'});
              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'}:".
Line 1595  sub EXT { Line 1686  sub EXT {
       if ($ENV{'request.course.id'}) {        if ($ENV{'request.course.id'}) {
 # ----------------------------------------------------- Cascading lookup scheme  # ----------------------------------------------------- Cascading lookup scheme
        my $symbp=&symbread();         my $symbp=&symbread();
        unless ($symbp) {  
            &logthis('No symb for '.$ENV{'request.filename'});  
        }   
        my $mapp=(split(/\_\_\_/,$symbp))[0];         my $mapp=(split(/\_\_\_/,$symbp))[0];
   
        my $symbparm=$symbp.'.'.$spacequalifierrest;         my $symbparm=$symbp.'.'.$spacequalifierrest;
Line 1642  sub EXT { Line 1730  sub EXT {
       }        }
   
 # -------------------------------------------------------- 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($_); }
Line 1661  sub EXT { Line 1746  sub EXT {
       if (($reply=~/^con_lost/) || ($reply=~/^error\:/)) {        if (($reply=~/^con_lost/) || ($reply=~/^error\:/)) {
   &logthis("<font color=blue>WARNING:".    &logthis("<font color=blue>WARNING:".
                 " Getting ".$reply." asking for ".$varname." for ".                  " Getting ".$reply." asking for ".$varname." for ".
                 $ENV{'course.'.$ENV{'request.course.id'}.$section.'.num'}.                  $ENV{'course.'.$ENV{'request.course.id'}.'.num'}.
                 ' at '.                  ' at '.
                 $ENV{'course.'.$ENV{'request.course.id'}.$section.'.domain'}.                  $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.
                 ' from '.                  ' from '.
                 $ENV{'course.'.$ENV{'request.course.id'}.$section.'.home'}.                  $ENV{'course.'.$ENV{'request.course.id'}.'.home'}.
                  "</font>");                   "</font>");
       }        }
 # ------------------------------------------------------ third, check map parms  # ------------------------------------------------------ third, check map parms
Line 1850  sub numval { Line 1935  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.95  
changed lines
  Added in v.1.120

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