Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.190 and 1.191

version 1.190, 2001/12/12 23:34:14 version 1.191, 2001/12/18 20:59:38
Line 63 Line 63
 # 12/5 Matthew Hall  # 12/5 Matthew Hall
 # 12/5 Guy Albertelli  # 12/5 Guy Albertelli
 # 12/6,12/7,12/12 Gerd Kortemeyer  # 12/6,12/7,12/12 Gerd Kortemeyer
   # 12/18 Scott Harrison
 #  #
 ###  ###
   
 # 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  
 # fileembstyle(ext)  : embed style in page for file extension  
 # filedescription(ext) : descriptor text for file extension  
 # allowed(short,url) : returns codes for allowed actions   
 #                      F: full access  
 #                      U,I,K: authentication modes (cxx only)  
 #                      '': forbidden  
 #                      1: user needs to choose course  
 #                      2: browse allowed  
 # definerole(rolename,sys,dom,cou) : define a custom role rolename  
 #                      set privileges in format of lonTabs/roles.tab for  
 #                      system, domain and course level,   
 # assignrole(udom,uname,url,role,end,start) : give a role to a user for the  
 #                      level given by url. Optional start and end dates  
 #                      (leave empty string or zero for "no date")   
 # assigncustomrole (udom,uname,url,rdom,rnam,rolename,end,start) : give a  
 #                      custom role to a user for the level given by url.  
 #                      Specify name and domain of role author, and role name  
 # revokerole (udom,uname,url,role) : Revoke a role for url  
 # revokecustomrole (udom,uname,url,rdom,rnam,rolename) : Revoke a custom role  
 # appenv(hash)       : adds hash to session environment  
 # delenv(varname)    : deletes all environment entries starting with varname  
 # store(hashref,symb,courseid,udom,uname)  
 #                    : stores hash permanently for this url  
 #                      hashref needs to be given, and should be a \%hashname  
 #                      the remaining args aren't required and if they aren't  
 #                      passed or are '' they will be derived from the ENV  
 # cstore(hashref,symb,courseid,udom,uname)  
 #                    : same as store but uses the critical interface to   
 #                      guarentee a store  
 # restore(symb,courseid,udom,uname)  
 #                    : returns hash for this symb, all args are optional  
 #                      if they aren't given they will be derived from the   
 #                      current enviroment  
 #  
 #  
 # for the next 6 functions udom and uname are optional  
 #         if supplied they use udom as the domain and uname  
 #         as the username for the function (supply a courseid  
 #         for the uname if you want a course database)  
 #         if not supplied it uses %ENV and looks at   
 #         user. attribute for the values  
 #  
 # eget(namesp,arrayref,udom,uname)  
 #                    : returns hash with keys from array  reference filled  
 #                      in from namesp (encrypts the return communication)  
 # get(namesp,arrayref,udom,uname)  
 #                    : returns hash with keys from array  reference filled  
 #                      in from namesp  
 # dump(namesp,udom,uname) : dumps the complete namespace into a hash  
 # del(namesp,array,udom,uname)  : deletes keys out of array from namesp  
 # put(namesp,hash,udom,uname)   : stores hash in namesp  
 # cput(namesp,hash,udom,uname)  : critical put  
 #  
 #  
 # ssi(url,hash)      : does a complete request cycle on url to localhost, posts  
 #                      hash  
 # coursedescription(id) : returns and caches course description for id  
 # repcopy(filename)  : replicate file  
 # dirlist(url)       : gets a directory listing  
 # directcondval(index) : reading condition value of single condition from   
 #                        state string  
 # condval(index)     : value of condition index based on state  
 # EXT(name)          : value of a variable  
 # symblist(map,hash) : Updates symbolic storage links  
 # symbread([filename]) : returns the data handle (filename optional)  
 # rndseed([symb,courseid,domain,uname])  
 #                    : returns a random seed, all arguments are optional,  
 #                      if they aren't sent it use the environment to derive  
 #                      them  
 #                      Note: if symb isn't sent and it can't get one from  
 #                      &symbread it will use the current time as it's return  
 # receipt()          : returns a receipt to be given out to users   
 # getfile(filename)  : returns the contents of filename, or a -1 if it can't  
 #                      be found, replicates and subscribes to the file  
 # filelocation(dir,file) : returns a fairly clean absolute reference to file   
 #                          from the directory dir  
 # hreflocation(dir,file) : same as filelocation, but for hrefs  
 # log(domain,user,home,msg) : write to permanent log for user  
 # usection(domain,user,courseid) : output of section name/number or '' for  
 #                                  "not in course" and '-1' for "no section"  
 # userenvironment(domain,user,what) : puts out any environment parameter   
 #                                     for a user  
 # idput(domain,hash) : writes IDs for users from hash (name=>id,name=>id)  
 # idget(domain,array): returns hash with usernames (id=>name,id=>name) for  
 #                      an array of IDs  
 # idrget(domain,array): returns hash with IDs for usernames (name=>id,...) for  
 #                       an array of names  
 # metadata(file,entry): returns the metadata entry for a file. entry='keys'  
 #                       returns a comma separated list of keys  
 #  
   
 package Apache::lonnet;  package Apache::lonnet;
   
 use strict;  use strict;
Line 325  sub critical { Line 229  sub critical {
   
 sub appenv {  sub appenv {
     my %newenv=@_;      my %newenv=@_;
     map {      foreach (keys %newenv) {
  if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) {   if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) {
             &logthis("<font color=blue>WARNING: ".              &logthis("<font color=blue>WARNING: ".
                 "Attempt to modify environment ".$_." to ".$newenv{$_}                  "Attempt to modify environment ".$_." to ".$newenv{$_}
Line 334  sub appenv { Line 238  sub appenv {
         } else {          } else {
             $ENV{$_}=$newenv{$_};              $ENV{$_}=$newenv{$_};
         }          }
     } keys %newenv;      }
   
     my $lockfh;      my $lockfh;
     unless ($lockfh=Apache::File->new("$ENV{'user.environment'}")) {      unless ($lockfh=Apache::File->new("$ENV{'user.environment'}")) {
Line 416  sub delenv { Line 320  sub delenv {
          $fh->close();           $fh->close();
          return 'error: '.$!;           return 'error: '.$!;
      }       }
      map {       foreach (@oldenv) {
  unless ($_=~/^$delthis/) { print $fh $_; }   unless ($_=~/^$delthis/) { print $fh $_; }
      } @oldenv;       }
      $fh->close();       $fh->close();
     }      }
     return 'ok';      return 'ok';
Line 571  sub idget { Line 475  sub idget {
 sub idrget {  sub idrget {
     my ($udom,@unames)=@_;      my ($udom,@unames)=@_;
     my %returnhash=();      my %returnhash=();
     map {      foreach (@unames) {
         $returnhash{$_}=(&userenvironment($udom,$_,'id'))[1];          $returnhash{$_}=(&userenvironment($udom,$_,'id'))[1];
     } @unames;      }
     return %returnhash;      return %returnhash;
 }  }
   
Line 582  sub idrget { Line 486  sub idrget {
 sub idput {  sub idput {
     my ($udom,%ids)=@_;      my ($udom,%ids)=@_;
     my %servers=();      my %servers=();
     map {      foreach (keys %ids) {
         my $uhom=&homeserver($_,$udom);          my $uhom=&homeserver($_,$udom);
         if ($uhom ne 'no_host') {          if ($uhom ne 'no_host') {
             my $id=&escape($ids{$_});              my $id=&escape($ids{$_});
Line 595  sub idput { Line 499  sub idput {
             }              }
             &critical('put:'.$udom.':'.$unam.':environment:id='.$id,$uhom);              &critical('put:'.$udom.':'.$unam.':environment:id='.$id,$uhom);
         }          }
     } keys %ids;      }
     map {      foreach (keys %servers) {
         &critical('idput:'.$udom.':'.$servers{$_},$_);          &critical('idput:'.$udom.':'.$servers{$_},$_);
     } keys %servers;      }
 }  }
   
 # ------------------------------------- Find the section of student in a course  # ------------------------------------- Find the section of student in a course
Line 607  sub usection { Line 511  sub usection {
     my ($udom,$unam,$courseid)=@_;      my ($udom,$unam,$courseid)=@_;
     $courseid=~s/\_/\//g;      $courseid=~s/\_/\//g;
     $courseid=~s/^(\w)/\/$1/;      $courseid=~s/^(\w)/\/$1/;
     map {      foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',
                           &homeserver($unam,$udom)))) {
         my ($key,$value)=split(/\=/,$_);          my ($key,$value)=split(/\=/,$_);
         $key=&unescape($key);          $key=&unescape($key);
         if ($key=~/^$courseid(?:\/)*(\w+)*\_st$/) {          if ($key=~/^$courseid(?:\/)*(\w+)*\_st$/) {
Line 624  sub usection { Line 529  sub usection {
             }               } 
             unless ($notactive) { return $section; }              unless ($notactive) { return $section; }
         }          }
     } split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',      }
                         &homeserver($unam,$udom)));  
     return '-1';      return '-1';
 }  }
   
Line 754  sub log { Line 658  sub log {
   
 sub flushcourselogs {  sub flushcourselogs {
     &logthis('Flushing course log buffers');      &logthis('Flushing course log buffers');
     map {      foreach (keys %courselogs) {
         my $crsid=$_;          my $crsid=$_;
         if (&reply('log:'.$coursedombuf{$crsid}.':'.          if (&reply('log:'.$coursedombuf{$crsid}.':'.
           &escape($courselogs{$crsid}),            &escape($courselogs{$crsid}),
Line 768  sub flushcourselogs { Line 672  sub flushcourselogs {
                delete $courselogs{$crsid};                 delete $courselogs{$crsid};
             }              }
         }                  }        
     } keys %courselogs;      }
     &logthis('Flushing access logs');      &logthis('Flushing access logs');
     map {      foreach (keys %accesshash) {
         my $entry=$_;          my $entry=$_;
         $entry=~/\_\_\_(\w+)\/(\w+)\/(.*)\_\_\_(\w+)$/;          $entry=~/\_\_\_(\w+)\/(\w+)\/(.*)\_\_\_(\w+)$/;
         my %temphash=($entry => $accesshash{$entry});          my %temphash=($entry => $accesshash{$entry});
         if (&Apache::lonnet::put('resevaldata',\%temphash,$1,$2) eq 'ok') {          if (&Apache::lonnet::put('resevaldata',\%temphash,$1,$2) eq 'ok') {
     delete $accesshash{$entry};      delete $accesshash{$entry};
         }          }
     } keys %accesshash;      }
     $dumpcount++;      $dumpcount++;
 }  }
   
Line 806  sub courseacclog { Line 710  sub courseacclog {
     my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'};      my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'};
     if ($what=~/(problem|exam|quiz|assess|survey|form)$/) {      if ($what=~/(problem|exam|quiz|assess|survey|form)$/) {
         $what.=':POST';          $what.=':POST';
  map {   foreach (keys %ENV) {
             if ($_=~/^form\.(.*)/) {              if ($_=~/^form\.(.*)/) {
  $what.=':'.$1.'='.$ENV{$_};   $what.=':'.$1.'='.$ENV{$_};
             }              }
         } keys %ENV;          }
     }      }
     &courselog($what);      &courselog($what);
 }  }
Line 956  sub devalidate { Line 860  sub devalidate {
 sub hash2str {  sub hash2str {
   my (%hash)=@_;    my (%hash)=@_;
   my $result='';    my $result='';
   map { $result.=escape($_).'='.escape($hash{$_}).'&'; } keys %hash;    foreach (keys %hash) { $result.=escape($_).'='.escape($hash{$_}).'&'; }
   $result=~s/\&$//;    $result=~s/\&$//;
   return $result;    return $result;
 }  }
Line 964  sub hash2str { Line 868  sub hash2str {
 sub str2hash {  sub str2hash {
   my ($string) = @_;    my ($string) = @_;
   my %returnhash;    my %returnhash;
   map {    foreach (split(/\&/,$string)) {
     my ($name,$value)=split(/\=/,$_);      my ($name,$value)=split(/\=/,$_);
     $returnhash{&unescape($name)}=&unescape($value);      $returnhash{&unescape($name)}=&unescape($value);
   } split(/\&/,$string);    }
   return %returnhash;    return %returnhash;
 }  }
   
Line 1117  sub store { Line 1021  sub store {
     if (!$stuname) { $stuname=$ENV{'user.name'}; }      if (!$stuname) { $stuname=$ENV{'user.name'}; }
     if (!$home) { $home=$ENV{'user.home'}; }      if (!$home) { $home=$ENV{'user.home'}; }
     my $namevalue='';      my $namevalue='';
     map {      foreach (keys %$storehash) {
         $namevalue.=escape($_).'='.escape($$storehash{$_}).'&';          $namevalue.=escape($_).'='.escape($$storehash{$_}).'&';
     } keys %$storehash;      }
     $namevalue=~s/\&$//;      $namevalue=~s/\&$//;
     &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue);      &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue);
     return reply("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");      return reply("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");
Line 1148  sub cstore { Line 1052  sub cstore {
     if (!$home) { $home=$ENV{'user.home'}; }      if (!$home) { $home=$ENV{'user.home'}; }
   
     my $namevalue='';      my $namevalue='';
     map {      foreach (keys %$storehash) {
         $namevalue.=escape($_).'='.escape($$storehash{$_}).'&';          $namevalue.=escape($_).'='.escape($$storehash{$_}).'&';
     } keys %$storehash;      }
     $namevalue=~s/\&$//;      $namevalue=~s/\&$//;
     &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);      &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);
     return critical      return critical
Line 1181  sub restore { Line 1085  sub restore {
     my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home");      my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home");
   
     my %returnhash=();      my %returnhash=();
     map {      foreach (split(/\&/,$answer)) {
  my ($name,$value)=split(/\=/,$_);   my ($name,$value)=split(/\=/,$_);
         $returnhash{&unescape($name)}=&unescape($value);          $returnhash{&unescape($name)}=&unescape($value);
     } split(/\&/,$answer);      }
     my $version;      my $version;
     for ($version=1;$version<=$returnhash{'version'};$version++) {      for ($version=1;$version<=$returnhash{'version'};$version++) {
        map {         foreach (split(/\:/,$returnhash{$version.':keys'})) {
           $returnhash{$_}=$returnhash{$version.':'.$_};            $returnhash{$_}=$returnhash{$version.':'.$_};
        } split(/\:/,$returnhash{$version.':keys'});         }
     }      }
     return %returnhash;      return %returnhash;
 }  }
Line 1240  sub rolesinit { Line 1144  sub rolesinit {
     my $thesestr;      my $thesestr;
   
     if ($rolesdump ne '') {      if ($rolesdump ne '') {
         map {          foreach (split(/&/,$rolesdump)) {
   if ($_!~/^rolesdef\&/) {    if ($_!~/^rolesdef\&/) {
             my ($area,$role)=split(/=/,$_);              my ($area,$role)=split(/=/,$_);
             $area=~s/\_\w\w$//;              $area=~s/\_\w\w$//;
Line 1296  sub rolesinit { Line 1200  sub rolesinit {
        }         }
             }              }
           }             } 
         } split(/&/,$rolesdump);          }
         my $adv=0;          my $adv=0;
         my $author=0;          my $author=0;
         map {          foreach (keys %allroles) {
             %thesepriv=();              %thesepriv=();
             if (($_!~/^st/) && ($_!~/^ta/) && ($_!~/^cm/)) { $adv=1; }              if (($_!~/^st/) && ($_!~/^ta/) && ($_!~/^cm/)) { $adv=1; }
             if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; }              if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; }
             map {              foreach (split(/:/,$allroles{$_})) {
                 if ($_ ne '') {                  if ($_ ne '') {
     my ($privilege,$restrictions)=split(/&/,$_);      my ($privilege,$restrictions)=split(/&/,$_);
                     if ($restrictions eq '') {                      if ($restrictions eq '') {
Line 1314  sub rolesinit { Line 1218  sub rolesinit {
                         }                          }
                     }                      }
                 }                  }
             } split(/:/,$allroles{$_});              }
             $thesestr='';              $thesestr='';
             map { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } keys %thesepriv;              foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; }
             $userroles.='user.priv.'.$_.'='.$thesestr."\n";              $userroles.='user.priv.'.$_.'='.$thesestr."\n";
         } keys %allroles;                      }
         $userroles.='user.adv='.$adv."\n".          $userroles.='user.adv='.$adv."\n".
             'user.author='.$author."\n";              'user.author='.$author."\n";
         $ENV{'user.adv'}=$adv;          $ENV{'user.adv'}=$adv;
Line 1331  sub rolesinit { Line 1235  sub rolesinit {
 sub get {  sub get {
    my ($namespace,$storearr,$udomain,$uname)=@_;     my ($namespace,$storearr,$udomain,$uname)=@_;
    my $items='';     my $items='';
    map {     foreach (@$storearr) {
        $items.=escape($_).'&';         $items.=escape($_).'&';
    } @$storearr;     }
    $items=~s/\&$//;     $items=~s/\&$//;
    if (!$udomain) { $udomain=$ENV{'user.domain'}; }     if (!$udomain) { $udomain=$ENV{'user.domain'}; }
    if (!$uname) { $uname=$ENV{'user.name'}; }     if (!$uname) { $uname=$ENV{'user.name'}; }
Line 1343  sub get { Line 1247  sub get {
    my @pairs=split(/\&/,$rep);     my @pairs=split(/\&/,$rep);
    my %returnhash=();     my %returnhash=();
    my $i=0;     my $i=0;
    map {     foreach (@$storearr) {
       $returnhash{$_}=unescape($pairs[$i]);        $returnhash{$_}=unescape($pairs[$i]);
       $i++;        $i++;
    } @$storearr;     }
    return %returnhash;     return %returnhash;
 }  }
   
Line 1355  sub get { Line 1259  sub get {
 sub del {  sub del {
    my ($namespace,$storearr,$udomain,$uname)=@_;     my ($namespace,$storearr,$udomain,$uname)=@_;
    my $items='';     my $items='';
    map {     foreach (@$storearr) {
        $items.=escape($_).'&';         $items.=escape($_).'&';
    } @$storearr;     }
    $items=~s/\&$//;     $items=~s/\&$//;
    if (!$udomain) { $udomain=$ENV{'user.domain'}; }     if (!$udomain) { $udomain=$ENV{'user.domain'}; }
    if (!$uname) { $uname=$ENV{'user.name'}; }     if (!$uname) { $uname=$ENV{'user.name'}; }
Line 1376  sub dump { Line 1280  sub dump {
    my $rep=reply("dump:$udomain:$uname:$namespace",$uhome);     my $rep=reply("dump:$udomain:$uname:$namespace",$uhome);
    my @pairs=split(/\&/,$rep);     my @pairs=split(/\&/,$rep);
    my %returnhash=();     my %returnhash=();
    map {     foreach (@pairs) {
       my ($key,$value)=split(/=/,$_);        my ($key,$value)=split(/=/,$_);
       $returnhash{unescape($key)}=unescape($value);        $returnhash{unescape($key)}=unescape($value);
    } @pairs;     }
    return %returnhash;     return %returnhash;
 }  }
   
Line 1391  sub put { Line 1295  sub put {
    if (!$uname) { $uname=$ENV{'user.name'}; }     if (!$uname) { $uname=$ENV{'user.name'}; }
    my $uhome=&homeserver($uname,$udomain);     my $uhome=&homeserver($uname,$udomain);
    my $items='';     my $items='';
    map {     foreach (keys %$storehash) {
        $items.=&escape($_).'='.&escape($$storehash{$_}).'&';         $items.=&escape($_).'='.&escape($$storehash{$_}).'&';
    } keys %$storehash;     }
    $items=~s/\&$//;     $items=~s/\&$//;
    return &reply("put:$udomain:$uname:$namespace:$items",$uhome);     return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
 }  }
Line 1406  sub cput { Line 1310  sub cput {
    if (!$uname) { $uname=$ENV{'user.name'}; }     if (!$uname) { $uname=$ENV{'user.name'}; }
    my $uhome=&homeserver($uname,$udomain);     my $uhome=&homeserver($uname,$udomain);
    my $items='';     my $items='';
    map {     foreach (keys %$storehash) {
        $items.=escape($_).'='.escape($$storehash{$_}).'&';         $items.=escape($_).'='.escape($$storehash{$_}).'&';
    } keys %$storehash;     }
    $items=~s/\&$//;     $items=~s/\&$//;
    return &critical("put:$udomain:$uname:$namespace:$items",$uhome);     return &critical("put:$udomain:$uname:$namespace:$items",$uhome);
 }  }
Line 1418  sub cput { Line 1322  sub cput {
 sub eget {  sub eget {
    my ($namespace,$storearr,$udomain,$uname)=@_;     my ($namespace,$storearr,$udomain,$uname)=@_;
    my $items='';     my $items='';
    map {     foreach (@$storearr) {
        $items.=escape($_).'&';         $items.=escape($_).'&';
    } @$storearr;     }
    $items=~s/\&$//;     $items=~s/\&$//;
    if (!$udomain) { $udomain=$ENV{'user.domain'}; }     if (!$udomain) { $udomain=$ENV{'user.domain'}; }
    if (!$uname) { $uname=$ENV{'user.name'}; }     if (!$uname) { $uname=$ENV{'user.name'}; }
Line 1429  sub eget { Line 1333  sub eget {
    my @pairs=split(/\&/,$rep);     my @pairs=split(/\&/,$rep);
    my %returnhash=();     my %returnhash=();
    my $i=0;     my $i=0;
    map {     foreach (@$storearr) {
       $returnhash{$_}=unescape($pairs[$i]);        $returnhash{$_}=unescape($pairs[$i]);
       $i++;        $i++;
    } @$storearr;     }
    return %returnhash;     return %returnhash;
 }  }
   
Line 1525  sub allowed { Line 1429  sub allowed {
   my $refuri=$ENV{'httpref.'.$orguri};    my $refuri=$ENV{'httpref.'.$orguri};
   
             unless ($refuri) {              unless ($refuri) {
                 map {                  foreach (keys %ENV) {
     if ($_=~/^httpref\..*\*/) {      if ($_=~/^httpref\..*\*/) {
  my $pattern=$_;   my $pattern=$_;
                         $pattern=~s/^httpref\.\/res\///;                          $pattern=~s/^httpref\.\/res\///;
Line 1535  sub allowed { Line 1439  sub allowed {
     $refuri=$ENV{$_};      $refuri=$ENV{$_};
                         }                          }
                     }                      }
                 } keys %ENV;                  }
             }              }
          if ($refuri) {            if ($refuri) { 
   $refuri=&declutter($refuri);    $refuri=&declutter($refuri);
Line 1691  sub allowed { Line 1595  sub allowed {
 sub definerole {  sub definerole {
   if (allowed('mcr','/')) {    if (allowed('mcr','/')) {
     my ($rolename,$sysrole,$domrole,$courole)=@_;      my ($rolename,$sysrole,$domrole,$courole)=@_;
     map {      foreach (split('/',$sysrole)) {
  my ($crole,$cqual)=split(/\&/,$_);   my ($crole,$cqual)=split(/\&/,$_);
         if ($pr{'cr:s'}!~/$crole/) { return "refused:s:$crole"; }          if ($pr{'cr:s'}!~/$crole/) { return "refused:s:$crole"; }
         if ($pr{'cr:s'}=~/$crole\&/) {          if ($pr{'cr:s'}=~/$crole\&/) {
Line 1699  sub definerole { Line 1603  sub definerole {
                return "refused:s:$crole&$cqual";                  return "refused:s:$crole&$cqual"; 
             }              }
         }          }
     } split('/',$sysrole);      }
     map {      foreach (split('/',$domrole)) {
  my ($crole,$cqual)=split(/\&/,$_);   my ($crole,$cqual)=split(/\&/,$_);
         if ($pr{'cr:d'}!~/$crole/) { return "refused:d:$crole"; }          if ($pr{'cr:d'}!~/$crole/) { return "refused:d:$crole"; }
         if ($pr{'cr:d'}=~/$crole\&/) {          if ($pr{'cr:d'}=~/$crole\&/) {
Line 1708  sub definerole { Line 1612  sub definerole {
                return "refused:d:$crole&$cqual";                  return "refused:d:$crole&$cqual"; 
             }              }
         }          }
     } split('/',$domrole);      }
     map {      foreach (split('/',$courole)) {
  my ($crole,$cqual)=split(/\&/,$_);   my ($crole,$cqual)=split(/\&/,$_);
         if ($pr{'cr:c'}!~/$crole/) { return "refused:c:$crole"; }          if ($pr{'cr:c'}!~/$crole/) { return "refused:c:$crole"; }
         if ($pr{'cr:c'}=~/$crole\&/) {          if ($pr{'cr:c'}=~/$crole\&/) {
Line 1717  sub definerole { Line 1621  sub definerole {
                return "refused:c:$crole&$cqual";                  return "refused:c:$crole&$cqual"; 
             }              }
         }          }
     } split('/',$courole);      }
     my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".      my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".
                 "$ENV{'user.domain'}:$ENV{'user.name'}:".                  "$ENV{'user.domain'}:$ENV{'user.name'}:".
         "rolesdef_$rolename=".          "rolesdef_$rolename=".
Line 1755  sub plaintext { Line 1659  sub plaintext {
     return $prp{$short};      return $prp{$short};
 }  }
   
 # ------------------------------------------------------------- Embedding Style  
   
 sub fileembstyle {  
     my $ending=lc(shift);  
     return $fe{$ending};  
 }  
   
 # ------------------------------------------------------------ Description Text  
   
 sub filedescription {  
     my $ending=lc(shift);  
     return $fd{$ending};  
 }  
   
 # ----------------------------------------------------------------- Assign Role  # ----------------------------------------------------------------- Assign Role
   
 sub assignrole {  sub assignrole {
Line 1937  sub writecoursepref { Line 1827  sub writecoursepref {
  return 'error: no such course';   return 'error: no such course';
     }      }
     my $cstring='';      my $cstring='';
     map {      foreach (keys %prefs) {
  $cstring.=escape($_).'='.escape($prefs{$_}).'&';   $cstring.=escape($_).'='.escape($prefs{$_}).'&';
     } keys %prefs;      }
     $cstring=~s/\&$//;      $cstring=~s/\&$//;
     return reply('put:'.$cdomain.':'.$cnum.':environment:'.$cstring,$chome);      return reply('put:'.$cdomain.':'.$cnum.':environment:'.$cstring,$chome);
 }  }
Line 2028  sub dirlist { Line 1918  sub dirlist {
        $tryserver);         $tryserver);
              if (($listing ne 'no_such_dir') && ($listing ne 'empty')               if (($listing ne 'no_such_dir') && ($listing ne 'empty')
               && ($listing ne 'con_lost')) {                && ($listing ne 'con_lost')) {
                 map {                  foreach (split(/:/,$listing)) {
                   my ($entry,@stat)=split(/&/,$_);                    my ($entry,@stat)=split(/&/,$_);
                   $allusers{$entry}=1;                    $allusers{$entry}=1;
                 } split(/:/,$listing);                  }
              }               }
   }    }
        }         }
        my $alluserstr='';         my $alluserstr='';
        map {         foreach (sort keys %allusers) {
            $alluserstr.=$_.'&user:';             $alluserstr.=$_.'&user:';
        } sort keys %allusers;         }
        $alluserstr=~s/:$//;         $alluserstr=~s/:$//;
        return split(/:/,$alluserstr);         return split(/:/,$alluserstr);
      }        } 
Line 2049  sub dirlist { Line 1939  sub dirlist {
    $alldom{$hostdom{$tryserver}}=1;     $alldom{$hostdom{$tryserver}}=1;
        }         }
        my $alldomstr='';         my $alldomstr='';
        map {         foreach (sort keys %alldom) {
           $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'&domain:';            $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'&domain:';
        } sort keys %alldom;         }
        $alldomstr=~s/:$//;         $alldomstr=~s/:$//;
        return split(/:/,$alldomstr);                return split(/:/,$alldomstr);       
    }     }
Line 2072  sub condval { Line 1962  sub condval {
     my $condidx=shift;      my $condidx=shift;
     my $result=0;      my $result=0;
     my $allpathcond='';      my $allpathcond='';
     map {      foreach (split(/\|/,$condidx)) {
        if (defined($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_})) {         if (defined($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_})) {
    $allpathcond.=     $allpathcond.=
                '('.$ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_}.')|';                 '('.$ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_}.')|';
        }         }
     } split(/\|/,$condidx);      }
     $allpathcond=~s/\|$//;      $allpathcond=~s/\|$//;
     if ($ENV{'request.course.id'}) {      if ($ENV{'request.course.id'}) {
        if ($allpathcond) {         if ($allpathcond) {
           my $operand='|';            my $operand='|';
   my @stack;    my @stack;
           map {             foreach ($allpathcond=~/(\d+|\(|\)|\&|\|)/g) {
               if ($_ eq '(') {                if ($_ eq '(') {
                  push @stack,($operand,$result)                   push @stack,($operand,$result)
               } elsif ($_ eq ')') {                } elsif ($_ eq ')') {
Line 2101  sub condval { Line 1991  sub condval {
                      $result=$result>$new?$new:$result;                       $result=$result>$new?$new:$result;
                   } else {                    } else {
                      $result=$result>$new?$result:$new;                       $result=$result>$new?$result:$new;
                   }                                      }
               }                }
           } ($allpathcond=~/(\d+|\(|\)|\&|\|)/g);            }
        }         }
     }      }
     return $result;      return $result;
Line 2237  sub EXT { Line 2127  sub EXT {
    &escape($courselevelr).'&'.&escape($courselevelm).'&'.&escape($courselevel),     &escape($courselevelr).'&'.&escape($courselevelm).'&'.&escape($courselevel),
    $ENV{'course.'.$ENV{'request.course.id'}.'.home'});     $ENV{'course.'.$ENV{'request.course.id'}.'.home'});
       if ($reply!~/^error\:/) {        if ($reply!~/^error\:/) {
   map {    foreach (split(/\&/,$reply)) {
       if ($_) { return &unescape($_); }        if ($_) { return &unescape($_); }
           } split(/\&/,$reply);            }
       }        }
       if (($reply=~/^con_lost/) || ($reply=~/^error\:/)) {        if (($reply=~/^con_lost/) || ($reply=~/^error\:/)) {
   &logthis("<font color=blue>WARNING:".    &logthis("<font color=blue>WARNING:".
Line 2349  sub metadata { Line 2239  sub metadata {
               } else {                } else {
                  $metacache{$uri.':packages'}=$package.$keyroot;                   $metacache{$uri.':packages'}=$package.$keyroot;
       }        }
               map {                foreach (keys %packagetab) {
   if ($_=~/^$package\&/) {    if ($_=~/^$package\&/) {
       my ($pack,$name,$subp)=split(/\&/,$_);        my ($pack,$name,$subp)=split(/\&/,$_);
                       my $value=$packagetab{$_};                        my $value=$packagetab{$_};
Line 2366  sub metadata { Line 2256  sub metadata {
                          $metacache{$uri.':'.$unikey.'.'.$subp}=$value;                           $metacache{$uri.':'.$unikey.'.'.$subp}=$value;
       }        }
                   }                    }
               } keys %packagetab;                }
              } else {               } else {
 #  #
 # This is not a package - some other kind of start tag  # This is not a package - some other kind of start tag
Line 2396  sub metadata { Line 2286  sub metadata {
  if (defined($depthcount)) { $depthcount++; } else    if (defined($depthcount)) { $depthcount++; } else 
                                            { $depthcount=0; }                                             { $depthcount=0; }
                  if ($depthcount<20) {                   if ($depthcount<20) {
      map {       foreach (split(/\,/,&metadata($uri,'keys',
                          $metathesekeys{$_}=1;  
      } split(/\,/,&metadata($uri,'keys',  
                                   $parser->get_text('/import'),$unikey,                                    $parser->get_text('/import'),$unikey,
                                   $depthcount));                                    $depthcount))) {
                            $metathesekeys{$_}=1;
        }
  }   }
              } else {                } else { 
   
Line 2408  sub metadata { Line 2298  sub metadata {
                  $unikey.='_'.$token->[2]->{'name'};                    $unikey.='_'.$token->[2]->{'name'}; 
       }        }
               $metathesekeys{$unikey}=1;                $metathesekeys{$unikey}=1;
               map {                foreach (@{$token->[3]}) {
   $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};    $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};
               } @{$token->[3]};                }
               unless (                unless (
                  $metacache{$uri.':'.$unikey}=$parser->get_text('/'.$entry)                   $metacache{$uri.':'.$unikey}=$parser->get_text('/'.$entry)
       ) { $metacache{$uri.':'.$unikey}=        ) { $metacache{$uri.':'.$unikey}=
Line 2439  sub symblist { Line 2329  sub symblist {
     if (($ENV{'request.course.fn'}) && (%newhash)) {      if (($ENV{'request.course.fn'}) && (%newhash)) {
         if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',          if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',
                       &GDBM_WRCREAT,0640)) {                        &GDBM_WRCREAT,0640)) {
     map {      foreach (keys %newhash) {
                 $hash{declutter($_)}=$mapname.'___'.$newhash{$_};                  $hash{declutter($_)}=$mapname.'___'.$newhash{$_};
             } keys %newhash;              }
             if (untie(%hash)) {              if (untie(%hash)) {
  return 'ok';   return 'ok';
             }              }
Line 2496  sub symbread { Line 2386  sub symbread {
                  } else {                   } else {
 # ------------------------------------------ There is more than one possibility  # ------------------------------------------ There is more than one possibility
                      my $realpossible=0;                       my $realpossible=0;
                      map {                       foreach (@possibilities) {
  my $file=$bighash{'src_'.$_};   my $file=$bighash{'src_'.$_};
                          if (&allowed('bre',$file)) {                           if (&allowed('bre',$file)) {
              my ($mapid,$resid)=split(/\./,$_);               my ($mapid,$resid)=split(/\./,$_);
Line 2506  sub symbread { Line 2396  sub symbread {
                                        '___'.$resid;                                         '___'.$resid;
                             }                              }
  }   }
                      } @possibilities;                       }
      if ($realpossible!=1) { $syval=''; }       if ($realpossible!=1) { $syval=''; }
                  }                   }
       }        }
Line 2615  sub filelocation { Line 2505  sub filelocation {
   
 sub hreflocation {  sub hreflocation {
     my ($dir,$file)=@_;      my ($dir,$file)=@_;
     unless (($_=~/^http:\/\//i) || ($_=~/^\//)) {      unless (($file=~/^http:\/\//i) || ($file=~/^\//)) {
        my $finalpath=filelocation($dir,$file);         my $finalpath=filelocation($dir,$file);
        $finalpath=~s/^\/home\/httpd\/html//;         $finalpath=~s/^\/home\/httpd\/html//;
        return $finalpath;         return $finalpath;
Line 2762  $dumpcount=0; Line 2652  $dumpcount=0;
 }  }
   
 1;  1;
   __END__
   
   =head1 NAME
   
   Apache::lonnet - TCP networking package
   
   =head1 SYNOPSIS
   
   Invoked by other LON-CAPA modules.
   
    &Apache::lonnet::SUBROUTINENAME(ARGUMENTS);
   
   =head1 INTRODUCTION
   
   This module provides subroutines which interact with the
   lonc/lond (TCP) network layer of LON-CAPA.
   
   This is part of the LearningOnline Network with CAPA project
   described at http://www.lon-capa.org.
   
   =head1 HANDLER SUBROUTINE
   
   There is no handler routine for this module.
   
   =head1 OTHER SUBROUTINES
   
   =over 4
   
   =item *
   
   logtouch() : make sure the logfile, lonnet.log, exists
   
   =item *
   
   logthis() : append message to lonnet.log
   
   =item *
   
   logperm() : append a permanent message to lonnet.perm.log
   
   =item *
   
   subreply() : non-critical communication, called by &reply
   
   =item *
   
   reply() : makes two attempts to pass message; logs refusals and rejections
   
   =item *
   
   reconlonc() : tries to reconnect lonc client processes.
   
   =item *
   
   critical() : passes a critical message to another server; if cannot get
   through then place message in connection buffer
   
   =item *
   
   appenv(%hash) : read in current user environment, append new environment
   values to make new user environment
   
   =item *
   
   delenv($varname) : read in current user environment, remove all values
   beginning with $varname, write new user environment (note: flock is used
   to prevent conflicting shared read/writes with file)
   
   =item *
   
   spareserver() : find server with least workload from spare.tab
   
   =item *
   
   queryauthenticate($uname,$udom) : try to determine user's current
   authentication scheme
   
   =item *
   
   authenticate($uname,$upass,$udom) : try to authenticate user from domain's lib
   servers (first use the current one)
   
   =item *
   
   homeserver($uname,$udom) : find the homebase for a user from domain's lib
   servers
   
   =item *
   
   idget($udom,@ids) : find the usernames behind a list of IDs (returns hash:
   id=>name,id=>name)
   
   =item *
   
   idrget($udom,@unames) : find the IDs behind a list of usernames (returns hash:
   name=>id,name=>id)
   
   =item *
   
   idput($udom,%ids) : store away a list of names and associated IDs
   
   =item *
   
   usection($domain,$user,$courseid) : output of section name/number or '' for
   "not in course" and '-1' for "no section"
   
   =item *
   
   userenvironment($domain,$user,$what) : puts out any environment parameter 
   for a user
   
   =item *
   
   subscribe($fname) : subscribe to a resource, return URL if possible
   
   =item *
   
   repcopy($filename) : replicate file
   
   =item *
   
   ssi($url,%hash) : server side include, does a complete request cycle on url to
   localhost, posts hash
   
   =item *
   
   log($domain,$name,$home,$message) : write to permanent log for user; use
   critical subroutine
   
   =item *
   
   flushcourselogs() : flush (save) buffer logs and access logs
   
   =item *
   
   courselog($what) : save message for course in hash
   
   =item *
   
   courseacclog($what) : save message for course using &courselog().  Perform
   special processing for specific resource types (problems, exams, quizzes, etc).
   
   =item *
   
   countacc($url) : count the number of accesses to a given URL
   
   =item *
   
   sub checkout($symb,$tuname,$tudom,$tcrsid) : check out an item
   
   =item *
   
   sub checkin($token) : check in an item
   
   =item *
   
   sub expirespread($uname,$udom,$stype,$usymb) : set expire date for spreadsheet
   
   =item *
   
   devalidate($symb) : devalidate spreadsheets
   
   =item *
   
   hash2str(%hash) : convert a hash into a string complete with escaping and '='
   and '&' separators
   
   =item *
   
   str2hash($string) : convert string to hash using unescaping and splitting on
   '=' and '&'
   
   =item *
   
   tmpreset($symb,$namespace,$domain,$stuname) : temporary storage
   
   =item *
   
   tmprestore($symb,$namespace,$domain,$stuname) : temporary restore
   
   =item *
   
   store($storehash,$symb,$namespace,$domain,$stuname) : stores hash permanently
   for this url; hashref needs to be given and should be a \%hashname; the
   remaining args aren't required and if they aren't passed or are '' they will
   be derived from the ENV
   
   =item *
   
   cstore($storehash,$symb,$namespace,$domain,$stuname) : same as store but
   uses critical subroutine
   
   =item *
   
   restore($symb,$namespace,$domain,$stuname) : returns hash for this symb;
   all args are optional
   
   =item *
   
   coursedescription($courseid) : course description
   
   =item *
   
   rolesinit($domain,$username,$authhost) : get user privileges
   
   =item *
   
   get($namespace,$storearr,$udomain,$uname) : returns hash with keys from array
   reference filled in from namesp ($udomain and $uname are optional)
   
   =item *
   
   del($namespace,$storearr,$udomain,$uname) : deletes keys out of array from
   namesp ($udomain and $uname are optional)
   
   =item *
   
   dump($namespace,$udomain,$uname) : dumps the complete namespace into a hash
   ($udomain and $uname are optional)
   
   =item *
   
   put($namespace,$storehash,$udomain,$uname) : stores hash in namesp
   ($udomain and $uname are optional)
   
   =item *
   
   cput($namespace,$storehash,$udomain,$uname) : critical put
   ($udomain and $uname are optional)
   
   =item *
   
   eget($namespace,$storearr,$udomain,$uname) : returns hash with keys from array
   reference filled in from namesp (encrypts the return communication)
   ($udomain and $uname are optional)
   
   =item *
   
   allowed($priv,$uri) : check for a user privilege; returns codes for allowed
   actions
    F: full access
    U,I,K: authentication modes (cxx only)
    '': forbidden
    1: user needs to choose course
    2: browse allowed
   
   =item *
   
   definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom
   role rolename set privileges in format of lonTabs/roles.tab for system, domain,
   and course level
   
   =item *
   
   metadata_query($query,$custom,$customshow) : make a metadata query against the
   network of library servers; returns file handle of where SQL and regex results
   will be stored for query
   
   =item *
   
   plaintext($short) : return value in %prp hash (rolesplain.tab); plain text
   explanation of a user role term
   
   =item *
   
   assignrole($udom,$uname,$url,$role,$end,$start) : assign role; give a role to a
   user for the level given by URL.  Optional start and end dates (leave empty
   string or zero for "no date")
   
   =item *
   
   modifyuserauth($udom,$uname,$umode,$upass) : modify user authentication
   
   =item *
   
   modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene) : 
   modify user
   
   =item *
   
   modifystudent($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
   $end,$start) : modify student
   
   =item *
   
   writecoursepref($courseid,%prefs) : write preferences for a course
   
   =item *
   
   createcourse($udom,$description,$url) : make/modify course
   
   =item *
   
   assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start) : assign
   custom role; give a custom role to a user for the level given by URL.  Specify
   name and domain of role author, and role name
   
   =item *
   
   revokerole($udom,$uname,$url,$role) : revoke a role for url
   
   =item *
   
   revokecustomrole($udom,$uname,$url,$role) : revoke a custom role
   
   =item *
   
   dirlist($uri) : return directory list based on URI
   
   =item *
   
   directcondval($number) : get current value of a condition; reads from a state
   string
   
   =item *
   
   condval($condidx) : value of condition index based on state
   
   =item *
   
   EXT($varname,$symbparm) : value of a variable
   
   =item *
   
   metadata($uri,$what,$liburi,$prefix,$depthcount) : get metadata; returns the
   metadata entry for a file; entry='keys', returns a comma separated list of keys
   
   =item *
   
   symblist($mapname,%newhash) : update symbolic storage links
   
   =item *
   
   symbread($filename) : return symbolic list entry (filename argument optional);
   returns the data handle
   
   =item *
   
   numval($salt) : return random seed value (addend for rndseed)
   
   =item *
   
   rndseed($symb,$courseid,$domain,$username) : create a random sum; returns
   a random seed, all arguments are optional, if they aren't sent it uses the
   environment to derive them. Note: if symb isn't sent and it can't get one
   from &symbread it will use the current time as its return value
   
   =item *
   
   ireceipt($funame,$fudom,$fucourseid,$fusymb) : return unique,
   unfakeable, receipt
   
   =item *
   
   receipt() : API to ireceipt working off of ENV values; given out to users
   
   =item *
   
   getfile($file) : serves up a file, returns the contents of a file or -1;
   replicates and subscribes to the file
   
   =item *
   
   filelocation($dir,$file) : returns file system location of a file based on URI;
   meant to be "fairly clean" absolute reference
   
   =item *
   
   hreflocation($dir,$file) : returns file system location or a URL; same as
   filelocation except for hrefs
   
   =item *
   
   declutter() : declutters URLs (remove docroot, beginning slashes, 'res' etc)
   
   =item *
   
   escape() : unpack non-word characters into CGI-compatible hex codes
   
   =item *
   
   unescape() : pack CGI-compatible hex codes into actual non-word ASCII character
   
   =item *
   
   goodbye() : flush course logs and log shutting down; it is called in srm.conf
   as a PerlChildExitHandler
   
   =back
   
   =cut

Removed from v.1.190  
changed lines
  Added in v.1.191


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