[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.561 and 1.589

version 1.561, 2004/11/04 23:43:07 version 1.589, 2005/01/18 22:09:14
Line 38  use vars Line 38  use vars
 qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom   qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom 
    %libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache     %libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache
    %courselogs %accesshash %userrolehash $processmarker $dumpcount      %courselogs %accesshash %userrolehash $processmarker $dumpcount 
    %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseresdatacache      %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %courseresdatacache 
    %userresdatacache %getsectioncache %domaindescription %domain_auth_def %domain_auth_arg_def      %userresdatacache %getsectioncache %domaindescription %domain_auth_def %domain_auth_arg_def 
    %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir);     %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit);
   
 use IO::Socket;  use IO::Socket;
 use GDBM_File;  use GDBM_File;
Line 157  sub reply { Line 157  sub reply {
     my ($cmd,$server)=@_;      my ($cmd,$server)=@_;
     unless (defined($hostname{$server})) { return 'no_such_host'; }      unless (defined($hostname{$server})) { return 'no_such_host'; }
     my $answer=subreply($cmd,$server);      my $answer=subreply($cmd,$server);
     if ($answer eq 'con_lost') {  
         #sleep 5;   
         #$answer=subreply($cmd,$server);  
         #if ($answer eq 'con_lost') {  
  #   &logthis("Second attempt con_lost on $server");  
         #   my $peerfile="$perlvar{'lonSockDir'}/$server";  
         #   my $client=IO::Socket::UNIX->new(Peer    =>"$peerfile",  
         #                                    Type    => SOCK_STREAM,  
         #                                    Timeout => 10)  
         #              or return "con_lost";  
         #   &logthis("Killing socket");  
         #   print $client "close_connection_exit\n";  
            #sleep 5;  
         #   $answer=subreply($cmd,$server);         
        #}     
     }  
     if (($answer=~/^refused/) || ($answer=~/^rejected/)) {      if (($answer=~/^refused/) || ($answer=~/^rejected/)) {
        &logthis("<font color=blue>WARNING:".         &logthis("<font color=blue>WARNING:".
                 " $cmd to $server returned $answer</font>");                  " $cmd to $server returned $answer</font>");
Line 220  sub critical { Line 204  sub critical {
     }      }
     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);  
  &reconlonc("$perlvar{'lonSockDir'}/$server");   &reconlonc("$perlvar{'lonSockDir'}/$server");
         my $pongreply=reply('pong',$server);   my $answer=reply($cmd,$server);
         &logthis("Ping/Pong for $server: $pingreply/$pongreply");  
         $answer=reply($cmd,$server);  
         if ($answer eq 'con_lost') {          if ($answer eq 'con_lost') {
             my $now=time;              my $now=time;
             my $middlename=$cmd;              my $middlename=$cmd;
Line 1188  sub ssi_body { Line 1169  sub ssi_body {
     my ($filelink,%form)=@_;      my ($filelink,%form)=@_;
     my $output=($filelink=~/^http\:/?&externalssi($filelink):      my $output=($filelink=~/^http\:/?&externalssi($filelink):
                                      &ssi($filelink,%form));                                       &ssi($filelink,%form));
     $output=~      $output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+// END LON-CAPA Internal\s*(-->)?\s||gs;
             s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs;  
     $output=~s/^.*?\<body[^\>]*\>//si;      $output=~s/^.*?\<body[^\>]*\>//si;
     $output=~s/(.*)\<\/body\s*\>.*?$/$1/si;      $output=~s/(.*)\<\/body\s*\>.*?$/$1/si;
     return $output;      return $output;
Line 1407  sub finishuserfileupload { Line 1387  sub finishuserfileupload {
     }      }
 # Save the file  # Save the file
     {      {
  #&Apache::lonnet::logthis("Saving to $filepath $file");   open(FH,'>'.$filepath.'/'.$file);
        open(my $fh,'>'.$filepath.'/'.$file);   print FH $ENV{'form.'.$formname};
        print $fh $ENV{'form.'.$formname};   close(FH);
        close($fh);  
     }      }
 # Notify homeserver to grep it  # Notify homeserver to grep it
 #  #
       &Apache::lonnet::logthis("fetching ".$path.$file);
     my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);      my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);
     if ($fetchresult eq 'ok') {      if ($fetchresult eq 'ok') {
 #  #
Line 1491  sub flushcourselogs { Line 1471  sub flushcourselogs {
         if ($courseidbuffer{$coursehombuf{$crsid}}) {          if ($courseidbuffer{$coursehombuf{$crsid}}) {
            $courseidbuffer{$coursehombuf{$crsid}}.='&'.             $courseidbuffer{$coursehombuf{$crsid}}.='&'.
  &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).   &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
                          '='.&escape($courseinstcodebuf{$crsid});                           ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid});
         } else {          } else {
            $courseidbuffer{$coursehombuf{$crsid}}=             $courseidbuffer{$coursehombuf{$crsid}}=
  &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).   &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
                          '='.&escape($courseinstcodebuf{$crsid});                           ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid});
         }              }
     }      }
 #  #
 # Write course id database (reverse lookup) to homeserver of courses   # Write course id database (reverse lookup) to homeserver of courses 
Line 1571  sub courselog { Line 1551  sub courselog {
        $ENV{'course.'.$ENV{'request.course.id'}.'.description'};         $ENV{'course.'.$ENV{'request.course.id'}.'.description'};
     $courseinstcodebuf{$ENV{'request.course.id'}}=      $courseinstcodebuf{$ENV{'request.course.id'}}=
        $ENV{'course.'.$ENV{'request.course.id'}.'.internal.coursecode'};         $ENV{'course.'.$ENV{'request.course.id'}.'.internal.coursecode'};
       $courseownerbuf{$ENV{'request.course.id'}}=
          $ENV{'course.'.$ENV{'request.course.id'}.'.internal.courseowner'};
     if (defined $courselogs{$ENV{'request.course.id'}}) {      if (defined $courselogs{$ENV{'request.course.id'}}) {
  $courselogs{$ENV{'request.course.id'}}.='&'.$what;   $courselogs{$ENV{'request.course.id'}}.='&'.$what;
     } else {      } else {
Line 1587  sub courseacclog { Line 1569  sub courseacclog {
     my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'};      my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'};
     if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|page)$/) {      if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|page)$/) {
         $what.=':POST';          $what.=':POST';
           # FIXME: Probably ought to escape things....
  foreach (keys %ENV) {   foreach (keys %ENV) {
             if ($_=~/^form\.(.*)/) {              if ($_=~/^form\.(.*)/) {
  $what.=':'.$1.'='.$ENV{$_};   $what.=':'.$1.'='.$ENV{$_};
             }              }
         }          }
       } elsif ($fnsymb =~ m:^/adm/searchcat:) {
           # FIXME: We should not be depending on a form parameter that someone
           # editing lonsearchcat.pm might change in the future.
           if ($ENV{'form.phase'} eq 'course_search') {
               $what.= ':POST';
               # FIXME: Probably ought to escape things....
               foreach my $element ('courseexp','crsfulltext','crsrelated',
                                    'crsdiscuss') {
                   $what.=':'.$element.'='.$ENV{'form.'.$element};
               }
           }
     }      }
     &courselog($what);      &courselog($what);
 }  }
Line 1643  sub get_course_adv_roles { Line 1637  sub get_course_adv_roles {
         if (($tend) && ($tend<$now)) { next; }          if (($tend) && ($tend<$now)) { next; }
         if (($tstart) && ($now<$tstart)) { next; }          if (($tstart) && ($now<$tstart)) { next; }
         my ($role,$username,$domain,$section)=split(/\:/,$_);          my ($role,$username,$domain,$section)=split(/\:/,$_);
    if ($username eq '' || $domain eq '') { next; }
  if ((&privileged($username,$domain)) &&    if ((&privileged($username,$domain)) && 
     (!$nothide{$username.':'.$domain})) { next; }      (!$nothide{$username.':'.$domain})) { next; }
         my $key=&plaintext($role);          my $key=&plaintext($role);
Line 1714  sub courseidput { Line 1709  sub courseidput {
 }  }
   
 sub courseiddump {  sub courseiddump {
     my ($domfilter,$descfilter,$sincefilter,$hostidflag,$hostidref)=@_;      my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$hostidflag,$hostidref)=@_;
     my %returnhash=();      my %returnhash=();
     unless ($domfilter) { $domfilter=''; }      unless ($domfilter) { $domfilter=''; }
     foreach my $tryserver (keys %libserv) {      foreach my $tryserver (keys %libserv) {
Line 1722  sub courseiddump { Line 1717  sub courseiddump {
     if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) {      if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) {
         foreach (          foreach (
                  split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.                   split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.
        $sincefilter.':'.&escape($descfilter),         $sincefilter.':'.&escape($descfilter).':'.
                                  &escape($instcodefilter).':'.&escape($ownerfilter),
                                $tryserver))) {                                 $tryserver))) {
     my ($key,$value)=split(/\=/,$_);      my ($key,$value)=split(/\=/,$_);
                     if (($key) && ($value)) {                      if (($key) && ($value)) {
Line 1743  sub get_first_access { Line 1739  sub get_first_access {
     my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();      my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();
     if ($argsymb) { $symb=$argsymb; }      if ($argsymb) { $symb=$argsymb; }
     my ($map,$id,$res)=&decode_symb($symb);      my ($map,$id,$res)=&decode_symb($symb);
     if ($type eq 'map') { $res=$map; }      if ($type eq 'map') {
     my %times=&get('firstaccesstimes',[$res],$udom,$uname);   $res=&symbread($map);
     return $times{$res};      } else {
    $res=$symb;
       }
       my %times=&get('firstaccesstimes',["$courseid\0$res"],$udom,$uname);
       return $times{"$courseid\0$res"};
 }  }
   
 sub set_first_access {  sub set_first_access {
     my ($type)=@_;      my ($type)=@_;
     my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();      my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();
     my ($map,$id,$res)=&decode_symb($symb);      my ($map,$id,$res)=&decode_symb($symb);
     if ($type eq 'map') { $res=$map; }      if ($type eq 'map') {
     my $firstaccess=&get_first_access($type);   $res=&symbread($map);
       } else {
    $res=$symb;
       }
       my $firstaccess=&get_first_access($type,$symb);
     if (!$firstaccess) {      if (!$firstaccess) {
  return &put('firstaccesstimes',{$res=>time},$udom,$uname);   return &put('firstaccesstimes',{"$courseid\0$res"=>time},$udom,$uname);
     }      }
     return 'already_set';      return 'already_set';
 }  }
Line 2361  sub privileged { Line 2365  sub privileged {
     my $now=time;      my $now=time;
     if ($rolesdump ne '') {      if ($rolesdump ne '') {
         foreach (split(/&/,$rolesdump)) {          foreach (split(/&/,$rolesdump)) {
     if ($_!~/^rolesdef\&/) {      if ($_!~/^rolesdef_/) {
  my ($area,$role)=split(/=/,$_);   my ($area,$role)=split(/=/,$_);
  $area=~s/\_\w\w$//;   $area=~s/\_\w\w$//;
  my ($trole,$tend,$tstart)=split(/_/,$role);   my ($trole,$tend,$tstart)=split(/_/,$role);
Line 2388  sub rolesinit { Line 2392  sub rolesinit {
     my $rolesdump=reply("dump:$domain:$username:roles",$authhost);      my $rolesdump=reply("dump:$domain:$username:roles",$authhost);
     if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; }      if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; }
     my %allroles=();      my %allroles=();
     my %thesepriv=();  
     my $now=time;      my $now=time;
     my $userroles="user.login.time=$now\n";      my $userroles="user.login.time=$now\n";
     my $thesestr;  
   
     if ($rolesdump ne '') {      if ($rolesdump ne '') {
         foreach (split(/&/,$rolesdump)) {          foreach (split(/&/,$rolesdump)) {
   if ($_!~/^rolesdef\&/) {    if ($_!~/^rolesdef_/) {
             my ($area,$role)=split(/=/,$_);              my ($area,$role)=split(/=/,$_);
             $area=~s/\_\w\w$//;      $area=~s/\_\w\w$//;
             my ($trole,$tend,$tstart)=split(/_/,$role);      
             $userroles.='user.role.'.$trole.'.'.$area.'='.              my ($trole,$tend,$tstart);
                         $tstart.'.'.$tend."\n";      if ($role=~/^cr/) { 
 # log the associated role with the area   ($trole,my $trest)=($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|);
             &userrolelog($trole,$username,$domain,$area,$tstart,$tend);   ($tend,$tstart)=split('_',$trest);
             if ($tend!=0) {      } else {
         if ($tend<$now) {   ($trole,$tend,$tstart)=split(/_/,$role);
             $trole='';      }
                 }               $userroles.=&set_arearole($trole,$area,$tstart,$tend,$domain,$username);
             }              if (($tend!=0) && ($tend<$now)) { $trole=''; }
             if ($tstart!=0) {              if (($tstart!=0) && ($tstart>$now)) { $trole=''; }
                 if ($tstart>$now) {  
                    $trole='';          
                 }  
             }  
             if (($area ne '') && ($trole ne '')) {              if (($area ne '') && ($trole ne '')) {
  my $spec=$trole.'.'.$area;   my $spec=$trole.'.'.$area;
  my ($tdummy,$tdomain,$trest)=split(/\//,$area);   my ($tdummy,$tdomain,$trest)=split(/\//,$area);
  if ($trole =~ /^cr\//) {   if ($trole =~ /^cr\//) {
     my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);                      &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
      my $homsvr=homeserver($rauthor,$rdomain);  
     if ($hostname{$homsvr} ne '') {  
  my ($rdummy,$roledef)=  
    &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);  
   
  if (($rdummy ne 'con_lost') && ($roledef ne '')) {  
     my ($syspriv,$dompriv,$coursepriv)=  
  split(/\_/,$roledef);  
     if (defined($syspriv)) {  
  $allroles{'cm./'}.=':'.$syspriv;  
  $allroles{$spec.'./'}.=':'.$syspriv;  
     }  
     if ($tdomain ne '') {  
  if (defined($dompriv)) {  
     $allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv;  
     $allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;  
  }  
  if ($trest ne '') {  
     if (defined($coursepriv)) {  
  $allroles{'cm.'.$area}.=':'.$coursepriv;  
  $allroles{$spec.'.'.$area}.=':'.$coursepriv;  
     }  
  }  
     }  
  }  
     }  
  } else {   } else {
     if (defined($pr{$trole.':s'})) {                      &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
  $allroles{'cm./'}.=':'.$pr{$trole.':s'};  
  $allroles{$spec.'./'}.=':'.$pr{$trole.':s'};  
     }  
     if ($tdomain ne '') {  
  if (defined($pr{$trole.':d'})) {  
     $allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};  
     $allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};  
  }  
  if ($trest ne '') {  
     if (defined($pr{$trole.':c'})) {  
  $allroles{'cm.'.$area}.=':'.$pr{$trole.':c'};  
  $allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'};  
     }  
  }  
     }  
  }   }
             }              }
           }             } 
         }          }
         my $adv=0;          my ($author,$adv) = &set_userprivs(\$userroles,\%allroles);
         my $author=0;  
         foreach (keys %allroles) {  
             %thesepriv=();  
             if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; }  
             foreach (split(/:/,$allroles{$_})) {  
                 if ($_ ne '') {  
     my ($privilege,$restrictions)=split(/&/,$_);  
                     if ($restrictions eq '') {  
  $thesepriv{$privilege}='F';  
                     } else {  
                         if ($thesepriv{$privilege} ne 'F') {  
     $thesepriv{$privilege}.=$restrictions;  
                         }  
                     }  
     if ($thesepriv{'adv'} eq 'F') { $adv=1; }  
                 }  
             }  
             $thesestr='';  
             foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; }  
             $userroles.='user.priv.'.$_.'='.$thesestr."\n";  
         }  
         $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 2494  sub rolesinit { Line 2430  sub rolesinit {
     return $userroles;        return $userroles;  
 }  }
   
   sub set_arearole {
       my ($trole,$area,$tstart,$tend,$domain,$username) = @_;
   # log the associated role with the area
       &userrolelog($trole,$username,$domain,$area,$tstart,$tend);
       return 'user.role.'.$trole.'.'.$area.'='.$tstart.'.'.$tend."\n";
   }
   
   sub custom_roleprivs {
       my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_;
       my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
       my $homsvr=homeserver($rauthor,$rdomain);
       if ($hostname{$homsvr} ne '') {
           my ($rdummy,$roledef)=
               &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);
           if (($rdummy ne 'con_lost') && ($roledef ne '')) {
               my ($syspriv,$dompriv,$coursepriv)=split(/\_/,$roledef);
               if (defined($syspriv)) {
                   $$allroles{'cm./'}.=':'.$syspriv;
                   $$allroles{$spec.'./'}.=':'.$syspriv;
               }
               if ($tdomain ne '') {
                   if (defined($dompriv)) {
                       $$allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv;
                       $$allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;
                   }
                   if (($trest ne '') && (defined($coursepriv))) {
                       $$allroles{'cm.'.$area}.=':'.$coursepriv;
                       $$allroles{$spec.'.'.$area}.=':'.$coursepriv;
                   }
               }
           }
       }
   }
   
   
   sub standard_roleprivs {
       my ($allroles,$trole,$tdomain,$spec,$trest,$area) = @_;
       if (defined($pr{$trole.':s'})) {
           $$allroles{'cm./'}.=':'.$pr{$trole.':s'};
           $$allroles{$spec.'./'}.=':'.$pr{$trole.':s'};
       }
       if ($tdomain ne '') {
           if (defined($pr{$trole.':d'})) {
               $$allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
               $$allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
           }
           if (($trest ne '') && (defined($pr{$trole.':c'}))) {
               $$allroles{'cm.'.$area}.=':'.$pr{$trole.':c'};
               $$allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'};
           }
       }
   }
   
   sub set_userprivs {
       my ($userroles,$allroles) = @_; 
       my $author=0;
       my $adv=0;
       foreach (keys %{$allroles}) {
           my %thesepriv=();
           if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; }
           foreach (split(/:/,$$allroles{$_})) {
               if ($_ ne '') {
                   my ($privilege,$restrictions)=split(/&/,$_);
                   if ($restrictions eq '') {
                       $thesepriv{$privilege}='F';
                   } elsif ($thesepriv{$privilege} ne 'F') {
                       $thesepriv{$privilege}.=$restrictions;
                   }
                   if ($thesepriv{'adv'} eq 'F') { $adv=1; }
               }
           }
           my $thesestr='';
           foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; }
           $$userroles.='user.priv.'.$_.'='.$thesestr."\n";
       }
       return ($author,$adv);
   }
   
 # --------------------------------------------------------------- get interface  # --------------------------------------------------------------- get interface
   
 sub get {  sub get {
Line 2771  sub customaccess { Line 2785  sub customaccess {
 # ------------------------------------------------- Check for a user privilege  # ------------------------------------------------- Check for a user privilege
   
 sub allowed {  sub allowed {
     my ($priv,$uri)=@_;      my ($priv,$uri,$symb)=@_;
     $uri=&deversion($uri);      $uri=&deversion($uri);
     my $orguri=$uri;      my $orguri=$uri;
     $uri=&declutter($uri);      $uri=&declutter($uri);
Line 3052  sub allowed { Line 3066  sub allowed {
   
    if ($thisallowed=~/X/) {     if ($thisallowed=~/X/) {
       if ($ENV{'acc.randomout'}) {        if ($ENV{'acc.randomout'}) {
          my $symb=&symbread($uri,1);   if (!$symb) { $symb=&symbread($uri,1); }
          if (($symb) && ($ENV{'acc.randomout'}=~/\&\Q$symb\E\&/)) {            if (($symb) && ($ENV{'acc.randomout'}=~/\&\Q$symb\E\&/)) { 
             return '';               return ''; 
          }           }
Line 3354  sub auto_instcode_format { Line 3368  sub auto_instcode_format {
     my $courses = '';      my $courses = '';
     my $homeserver;      my $homeserver;
     if ($caller eq 'global') {      if ($caller eq 'global') {
         $homeserver = $perlvar{'lonHostID'};          foreach my $tryserver (keys %libserv) {
               if ($hostdom{$tryserver} eq $codedom) {
                   $homeserver = $tryserver;
                   last;
               }
           }
           if (($ENV{'user.name'}) && ($ENV{'user.domain'} eq $codedom)) {
               $homeserver = &homeserver($ENV{'user.name'},$codedom);
           }
     } else {      } else {
         $homeserver = &homeserver($caller,$codedom);          $homeserver = &homeserver($caller,$codedom);
     }      }
     my $host=$hostname{$homeserver};  
     foreach (keys %{$instcodes}) {      foreach (keys %{$instcodes}) {
         $courses .= &escape($_).'='.&escape($$instcodes{$_}).'&';          $courses .= &escape($_).'='.&escape($$instcodes{$_}).'&';
     }      }
Line 3685  sub writecoursepref { Line 3706  sub writecoursepref {
 # ---------------------------------------------------------- Make/modify course  # ---------------------------------------------------------- Make/modify course
   
 sub createcourse {  sub createcourse {
     my ($udom,$description,$url,$course_server,$nonstandard,$inst_code)=@_;      my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,$course_owner)=@_;
     $url=&declutter($url);      $url=&declutter($url);
     my $cid='';      my $cid='';
     unless (&allowed('ccc',$udom)) {      unless (&allowed('ccc',$udom)) {
Line 3720  sub createcourse { Line 3741  sub createcourse {
 # ----------------------------------------------------------------- Course made  # ----------------------------------------------------------------- Course made
 # log existence  # log existence
     &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description).      &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description).
                  '='.&escape($inst_code),$uhome);                   ':'.&escape($inst_code).':'.&escape($course_owner),$uhome);
     &flushcourselogs();      &flushcourselogs();
 # set toplevel url  # set toplevel url
     my $topurl=$url;      my $topurl=$url;
Line 3781  sub diskusage { Line 3802  sub diskusage {
     return $listing;      return $listing;
 }  }
   
   sub is_locked {
       my ($file_name, $domain, $user) = @_;
       my @check;
       my $is_locked;
       push @check, $file_name;
       my %locked = &Apache::lonnet::get('file_permissions',\@check,
                                           $ENV{'user.domain'},$ENV{'user.name'});
       if (ref($locked{$file_name}) eq 'ARRAY') {
           $is_locked = 'true';
       } else {
           $is_locked = 'false';
       }
   }
   
 # ------------------------------------------------------------- Mark as Read Only  # ------------------------------------------------------------- Mark as Read Only
   
 sub mark_as_readonly {  sub mark_as_readonly {
Line 3793  sub mark_as_readonly { Line 3828  sub mark_as_readonly {
     return;      return;
 }  }
   
   # ------------------------------------------------------------Save Selected Files
   
   sub save_selected_files {
       my ($user, $path, @files) = @_;
       my $filename = $user."savedfiles";
       my @other_files = &files_not_in_path($user, $path);
       open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
       foreach my $file (@files) {
           print (OUT $ENV{'form.currentpath'}.$file."\n");
       }
       foreach my $file (@other_files) {
           print (OUT $file."\n");
       }
       close (OUT);
       return 'ok';
   }
   
   sub clear_selected_files {
       my ($user) = @_;
       my $filename = $user."savedfiles";
       open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
       print (OUT undef);
       close (OUT);
       return ("ok");    
   }
   
   sub files_in_path {
       my ($user, $path) = @_;
       my $filename = $user."savedfiles";
       my %return_files;
       open (IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
       while (my $line_in = <IN>) {
           chomp ($line_in);
           my @paths_and_file = split (m!/!, $line_in);
           my $file_part = pop (@paths_and_file);
           my $path_part = join ('/', @paths_and_file);
           $path_part.='/';
           my $path_and_file = $path_part.$file_part;
           if ($path_part eq $path) {
               $return_files{$file_part}= 'selected';
           }
       }
       close (IN);
       return (\%return_files);
   }
   
   # called in portfolio select mode, to show files selected NOT in current directory
   sub files_not_in_path {
       my ($user, $path) = @_;
       my $filename = $user."savedfiles";
       my @return_files;
       my $path_part;
       open (IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
       while (<IN>) {
           #ok, I know it's clunky, but I want it to work
           my @paths_and_file = split m!/!, $_;
           my $file_part = pop (@paths_and_file);
           chomp ($file_part);
           my $path_part = join ('/', @paths_and_file);
           $path_part .= '/';
           my $path_and_file = $path_part.$file_part;
           if ($path_part ne $path) {
               push (@return_files, ($path_and_file));
           }
       }
       close (OUT);
       return (@return_files);
   }
   
 #--------------------------------------------------------------Get Marked as Read Only  #--------------------------------------------------------------Get Marked as Read Only
   
 sub get_marked_as_readonly {  sub get_marked_as_readonly {
     my ($domain,$user,$what) = @_;      my ($domain,$user,$what) = @_;
     my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user);      my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user);
     my @readonly_files = [];      my @readonly_files;
     while ((my $file_name, my $value) = each %current_permissions) {      while (my ($file_name,$value) = each(%current_permissions)) {
         if (ref($value) eq "ARRAY"){          if (ref($value) eq "ARRAY"){
             foreach my $stored_what (@{$value}) {              foreach my $stored_what (@{$value}) {
                 if ($stored_what eq $what) {                  if ($stored_what eq $what) {
                     push(@readonly_files, $file_name);                      push(@readonly_files, $file_name);
                   } elsif (!defined($what)) {
                       push(@readonly_files, $file_name);
                 }                  }
             }              }
         }           } 
     }      }
     return @readonly_files;      return @readonly_files;
 }  }
   #-----------------------------------------------------------Get Marked as Read Only Hash
   
   sub get_marked_as_readonly_hash {
       my ($domain,$user,$what) = @_;
       my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user);
       my %readonly_files;
       while (my ($file_name,$value) = each(%current_permissions)) {
           if (ref($value) eq "ARRAY"){
               foreach my $stored_what (@{$value}) {
                   if ($stored_what eq $what) {
                       $readonly_files{$file_name} = 'locked';
                   } elsif (!defined($what)) {
                       $readonly_files{$file_name} = 'locked';
                   }
               }
           } 
       }
       return %readonly_files;
   }
 # ------------------------------------------------------------ Unmark as Read Only  # ------------------------------------------------------------ Unmark as Read Only
   
 sub unmark_as_readonly {  sub unmark_as_readonly {
Line 3820  sub unmark_as_readonly { Line 3944  sub unmark_as_readonly {
     my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user);      my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user);
     my @readonly_files = &Apache::lonnet::get_marked_as_readonly($domain,$user,$what);      my @readonly_files = &Apache::lonnet::get_marked_as_readonly($domain,$user,$what);
     foreach my $file(@readonly_files){      foreach my $file(@readonly_files){
                   my $current_locks = $current_permissions{$file};
           my @new_locks;
           my @del_keys;
           if (ref($current_locks) eq "ARRAY"){
               foreach my $locker (@{$current_locks}) {
                   unless ($locker eq $what) {
                       push(@new_locks, $what);
                   }
               }
               if (@new_locks > 0) {
                   $current_permissions{$file} = \@new_locks;
               } else {
                   push(@del_keys, $file);
                   &Apache::lonnet::del('file_permissions',\@del_keys, $domain, $user);
                   delete $current_permissions{$file};
               }
           }
     }      }
     &Apache::lonnet::put('file_permissions',\%current_permissions,$domain,$user);      &Apache::lonnet::put('file_permissions',\%current_permissions,$domain,$user);
     return;      return;
Line 4306  sub packages_tab_default { Line 4446  sub packages_tab_default {
  if (defined($packagetab{"$pack_type&$name&default"})) {   if (defined($packagetab{"$pack_type&$name&default"})) {
     return $packagetab{"$pack_type&$name&default"};      return $packagetab{"$pack_type&$name&default"};
  }   }
    if ($pack_type eq 'part') { $pack_part='0'; }
  if (defined($packagetab{$pack_type."_".$pack_part."&$name&default"})) {   if (defined($packagetab{$pack_type."_".$pack_part."&$name&default"})) {
     return $packagetab{$pack_type."_".$pack_part."&$name&default"};      return $packagetab{$pack_type."_".$pack_part."&$name&default"};
  }   }
Line 4587  sub gettitle { Line 4728  sub gettitle {
     my $symb=&symbread($urlsymb);      my $symb=&symbread($urlsymb);
     if ($symb) {      if ($symb) {
  my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600);   my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600);
  if (defined($cached)) { return $result; }   if (defined($cached)) { 
       return $result;
    }
  my ($map,$resid,$url)=&decode_symb($symb);   my ($map,$resid,$url)=&decode_symb($symb);
  my $title='';   my $title='';
  my %bighash;   my %bighash;
Line 4663  sub symbverify { Line 4806  sub symbverify {
                if (                 if (
   &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)    &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)
    eq $symb) {      eq $symb) { 
                   $okay=1;      if (($ENV{'request.role.adv'}) ||
                }         $bighash{'encrypted_'.$_} eq $ENV{'request.enc'}) {
          $okay=1; 
      }
          }
    }     }
         }          }
  untie(%bighash);   untie(%bighash);
Line 4676  sub symbverify { Line 4822  sub symbverify {
   
 sub symbclean {  sub symbclean {
     my $symb=shift;      my $symb=shift;
       if ($symb=~m|^/enc/|) { $symb=&Apache::lonenc::unencrypted($symb); }
 # remove version from map  # remove version from map
     $symb=~s/\.(\d+)\.(\w+)\_\_\_/\.$2\_\_\_/;      $symb=~s/\.(\d+)\.(\w+)\_\_\_/\.$2\_\_\_/;
   
Line 4697  sub encode_symb { Line 4843  sub encode_symb {
 }  }
   
 sub decode_symb {  sub decode_symb {
     my ($map,$resid,$url)=split(/\_\_\_/,shift);      my $symb=shift;
       if ($symb=~m|^/enc/|) { $symb=&Apache::lonenc::unencrypted($symb); }
       my ($map,$resid,$url)=split(/___/,$symb);
     return (&fixversion($map),$resid,&fixversion($url));      return (&fixversion($map),$resid,&fixversion($url));
 }  }
   
Line 4746  sub symbread { Line 4894  sub symbread {
  }   }
  $thisfn=$ENV{'request.filename'};   $thisfn=$ENV{'request.filename'};
     }      }
       if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }
 # is that filename actually a symb? Verify, clean, and return  # is that filename actually a symb? Verify, clean, and return
     if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) {      if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) {
  if (&symbverify($thisfn,$1)) {   if (&symbverify($thisfn,$1)) {
Line 4836  sub numval { Line 4985  sub numval {
     $txt=~tr/U-Z/0-5/;      $txt=~tr/U-Z/0-5/;
     $txt=~tr/u-z/0-5/;      $txt=~tr/u-z/0-5/;
     $txt=~s/\D//g;      $txt=~s/\D//g;
       if ($_64bit) { if ($txt > 2**32) { return -1; } }
     return int($txt);      return int($txt);
 }  }
   
Line 4851  sub numval2 { Line 5001  sub numval2 {
     my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt);      my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt);
     my $total;      my $total;
     foreach my $val (@txts) { $total+=$val; }      foreach my $val (@txts) { $total+=$val; }
       if ($_64bit) { if ($total > 2**32) { return -1; } }
     return int($total);      return int($total);
 }  }
   
   sub numval3 {
       use integer;
       my $txt=shift;
       $txt=~tr/A-J/0-9/;
       $txt=~tr/a-j/0-9/;
       $txt=~tr/K-T/0-9/;
       $txt=~tr/k-t/0-9/;
       $txt=~tr/U-Z/0-5/;
       $txt=~tr/u-z/0-5/;
       $txt=~s/\D//g;
       my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt);
       my $total;
       foreach my $val (@txts) { $total+=$val; }
       if ($_64bit) { $total=(($total<<32)>>32); }
       return $total;
   }
   
 sub latest_rnd_algorithm_id {  sub latest_rnd_algorithm_id {
     return '64bit3';      return '64bit4';
 }  }
   
 sub get_rand_alg {  sub get_rand_alg {
Line 4867  sub get_rand_alg { Line 5035  sub get_rand_alg {
     return &latest_rnd_algorithm_id();      return &latest_rnd_algorithm_id();
 }  }
   
   sub validCODE {
       my ($CODE)=@_;
       if (defined($CODE) && $CODE ne '' && $CODE =~ /^\w+$/) { return 1; }
       return 0;
   }
   
 sub getCODE {  sub getCODE {
     if (defined($ENV{'form.CODE'})) { return $ENV{'form.CODE'}; }      if (&validCODE($ENV{'form.CODE'})) { return $ENV{'form.CODE'}; }
     if (defined($Apache::lonhomework::parsing_a_problem) &&      if (defined($Apache::lonhomework::parsing_a_problem) &&
  defined($Apache::lonhomework::history{'resource.CODE'})) {   &validCODE($Apache::lonhomework::history{'resource.CODE'})) {
  return $Apache::lonhomework::history{'resource.CODE'};   return $Apache::lonhomework::history{'resource.CODE'};
     }      }
     return undef;      return undef;
Line 4888  sub rndseed { Line 5062  sub rndseed {
     if (!$username) { $username=$wusername }      if (!$username) { $username=$wusername }
     my $which=&get_rand_alg();      my $which=&get_rand_alg();
     if (defined(&getCODE())) {      if (defined(&getCODE())) {
  return &rndseed_CODE_64bit($symb,$courseid,$domain,$username);   if ($which eq '64bit4') {
       return &rndseed_CODE_64bit4($symb,$courseid,$domain,$username);
    } else {
       return &rndseed_CODE_64bit($symb,$courseid,$domain,$username);
    }
       } elsif ($which eq '64bit4') {
    return &rndseed_64bit4($symb,$courseid,$domain,$username);
     } elsif ($which eq '64bit3') {      } elsif ($which eq '64bit3') {
  return &rndseed_64bit3($symb,$courseid,$domain,$username);   return &rndseed_64bit3($symb,$courseid,$domain,$username);
     } elsif ($which eq '64bit2') {      } elsif ($which eq '64bit2') {
Line 4912  sub rndseed_32bit { Line 5092  sub rndseed_32bit {
  my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;   my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;
  #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");   #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
  #&Apache::lonxml::debug("rndseed :$num:$symb");   #&Apache::lonxml::debug("rndseed :$num:$symb");
    if ($_64bit) { $num=(($num<<32)>>32); }
  return $num;   return $num;
     }      }
 }  }
Line 4932  sub rndseed_64bit { Line 5113  sub rndseed_64bit {
  my $num2=$nameseed+$domainseed+$courseseed;   my $num2=$nameseed+$domainseed+$courseseed;
  #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");   #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
  #&Apache::lonxml::debug("rndseed :$num:$symb");   #&Apache::lonxml::debug("rndseed :$num:$symb");
    if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
    if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
  return "$num1,$num2";   return "$num1,$num2";
     }      }
 }  }
Line 4975  sub rndseed_64bit3 { Line 5158  sub rndseed_64bit3 {
  my $num1=$symbchck+$symbseed+$namechck;   my $num1=$symbchck+$symbseed+$namechck;
  my $num2=$nameseed+$domainseed+$courseseed;   my $num2=$nameseed+$domainseed+$courseseed;
  #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");   #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
  #&Apache::lonxml::debug("rndseed :$num:$symb");   #&Apache::lonxml::debug("rndseed :$num1:$num2:$_64bit");
    if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
   
    return "$num1:$num2";
       }
   }
   
   sub rndseed_64bit4 {
       my ($symb,$courseid,$domain,$username)=@_;
       {
    use integer;
    # strings need to be an even # of cahracters long, it it is odd the
           # last characters gets thrown away
    my $symbchck=unpack("%32S*",$symb.' ') << 21;
    my $symbseed=numval3($symb) << 10;
    my $namechck=unpack("%32S*",$username.' ');
   
    my $nameseed=numval3($username) << 21;
    my $domainseed=unpack("%32S*",$domain.' ') << 10;
    my $courseseed=unpack("%32S*",$courseid.' ');
   
    my $num1=$symbchck+$symbseed+$namechck;
    my $num2=$nameseed+$domainseed+$courseseed;
    #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
    #&Apache::lonxml::debug("rndseed :$num1:$num2:$_64bit");
    if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
   
  return "$num1:$num2";   return "$num1:$num2";
     }      }
 }  }
Line 4993  sub rndseed_CODE_64bit { Line 5202  sub rndseed_CODE_64bit {
  my $num2=$CODEseed+$courseseed+$symbchck;   my $num2=$CODEseed+$courseseed+$symbchck;
  #&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");   #&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");
  #&Apache::lonxml::debug("rndseed :$num1:$num2:$symb");   #&Apache::lonxml::debug("rndseed :$num1:$num2:$symb");
    if ($_64bit) { $num1=(($num1<<32)>>32); }
    if ($_64bit) { $num2=(($num2<<32)>>32); }
    return "$num1:$num2";
       }
   }
   
   sub rndseed_CODE_64bit4 {
       my ($symb,$courseid,$domain,$username)=@_;
       {
    use integer;
    my $symbchck=unpack("%32S*",$symb.' ') << 16;
    my $symbseed=numval3($symb);
    my $CODEchck=unpack("%32S*",&getCODE().' ') << 16;
    my $CODEseed=numval3(&getCODE());
    my $courseseed=unpack("%32S*",$courseid.' ');
    my $num1=$symbseed+$CODEchck;
    my $num2=$CODEseed+$courseseed+$symbchck;
    #&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");
    #&Apache::lonxml::debug("rndseed :$num1:$num2:$symb");
    if ($_64bit) { $num1=(($num1<<32)>>32); }
    if ($_64bit) { $num2=(($num2<<32)>>32); }
  return "$num1:$num2";   return "$num1:$num2";
     }      }
 }  }
Line 5281  sub current_machine_ids { Line 5511  sub current_machine_ids {
   
 sub declutter {  sub declutter {
     my $thisfn=shift;      my $thisfn=shift;
       if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }
     $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//;      $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//;
     $thisfn=~s/^\///;      $thisfn=~s/^\///;
     $thisfn=~s/^res\///;      $thisfn=~s/^res\///;
Line 5334  sub thaw_unescape { Line 5565  sub thaw_unescape {
 }  }
   
 sub mod_perl_version {  sub mod_perl_version {
       return 1;
     if (defined($perlvar{'MODPERL2'})) {      if (defined($perlvar{'MODPERL2'})) {
  return 2;   return 2;
     }      }
     return 1;  
 }  }
   
 sub correct_line_ends {  sub correct_line_ends {
Line 5370  BEGIN { Line 5601  BEGIN {
 # ----------------------------------- Read loncapa.conf and loncapa_apache.conf  # ----------------------------------- Read loncapa.conf and loncapa_apache.conf
     unless ($readit) {      unless ($readit) {
 {  {
       # FIXME: Use LONCAPA::Configuration::read_conf here and omit next block
     open(my $config,"</etc/httpd/conf/loncapa.conf");      open(my $config,"</etc/httpd/conf/loncapa.conf");
   
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
Line 5513  $dumpcount=0; Line 5745  $dumpcount=0;
 &logtouch();  &logtouch();
 &logthis('<font color=yellow>INFO: Read configuration</font>');  &logthis('<font color=yellow>INFO: Read configuration</font>');
 $readit=1;  $readit=1;
       {
    use integer;
    my $test=(2**32)+1;
    if ($test != 0) { $_64bit=1; } else { $_64bit=0; }
    &logthis(" Detected 64bit platform ($_64bit)");
       }
 }  }
 }  }
   
Line 5999  returns the data handle Line 6237  returns the data handle
 =item *  =item *
   
 symbverify($symb,$thisfn) : verifies that $symb actually exists and is  symbverify($symb,$thisfn) : verifies that $symb actually exists and is
 a possible symb for the URL in $thisfn, returns a 1 on success, 0 on  a possible symb for the URL in $thisfn, and if is an encryypted
 failure, user must be in a course, as it assumes the existance of the  resource that the user accessed using /enc/ returns a 1 on success, 0
 course initi hash, and uses $ENV('request.course.id'}  on failure, user must be in a course, as it assumes the existance of
   the course initial hash, and uses $ENV('request.course.id'}
   
   
 =item *  =item *
Removed from v.1.561  
changed lines
  Added in v.1.589

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