[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.663 and 1.682

version 1.663, 2005/10/12 16:50:37 version 1.682, 2005/11/21 19:08:29
Line 49  use Apache::Constants qw(:common :http); Line 49  use Apache::Constants qw(:common :http);
 use HTML::LCParser;  use HTML::LCParser;
 use HTML::Parser;  use HTML::Parser;
 use Fcntl qw(:flock);  use Fcntl qw(:flock);
 use Apache::lonlocal;  
 use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze);  use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze);
 use Time::HiRes qw( gettimeofday tv_interval );  use Time::HiRes qw( gettimeofday tv_interval );
 use Cache::Memcached;  use Cache::Memcached;
   use Digest::MD5;
   
 my $readit;  my $readit;
 my $max_connection_retries = 10;     # Or some such value.  my $max_connection_retries = 10;     # Or some such value.
   
Line 166  sub reply { Line 167  sub reply {
     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=~/^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>");
     }      }
     return $answer;      return $answer;
Line 190  sub reconlonc { Line 191  sub reconlonc {
             sleep 5;              sleep 5;
             if (-e "$peerfile") { return; }              if (-e "$peerfile") { return; }
             &logthis(              &logthis(
   "<font color=blue>WARNING: $peerfile still not there, giving up</font>");    "<font color=\"blue\">WARNING: $peerfile still not there, giving up</font>");
         } else {          } else {
     &logthis(      &logthis(
                "<font color=blue>WARNING:".                 "<font color=\"blue\">WARNING:".
                " lonc at pid $loncpid not responding, giving up</font>");                 " lonc at pid $loncpid not responding, giving up</font>");
         }          }
     } else {      } else {
      &logthis('<font color=blue>WARNING: lonc not running, giving up</font>');       &logthis('<font color="blue">WARNING: lonc not running, giving up</font>');
     }      }
 }  }
   
Line 206  sub reconlonc { Line 207  sub reconlonc {
 sub critical {  sub critical {
     my ($cmd,$server)=@_;      my ($cmd,$server)=@_;
     unless ($hostname{$server}) {      unless ($hostname{$server}) {
         &logthis("<font color=blue>WARNING:".          &logthis("<font color=\"blue\">WARNING:".
                " Critical message to unknown server ($server)</font>");                 " Critical message to unknown server ($server)</font>");
         return 'no_such_host';          return 'no_such_host';
     }      }
Line 240  sub critical { Line 241  sub critical {
             }              }
             chomp($wcmd);              chomp($wcmd);
             if ($wcmd eq $cmd) {              if ($wcmd eq $cmd) {
  &logthis("<font color=blue>WARNING: ".   &logthis("<font color=\"blue\">WARNING: ".
                          "Connection buffer $dfilename: $cmd</font>");                           "Connection buffer $dfilename: $cmd</font>");
                 &logperm("D:$server:$cmd");                  &logperm("D:$server:$cmd");
         return 'con_delayed';          return 'con_delayed';
             } else {              } else {
                 &logthis("<font color=red>CRITICAL:"                  &logthis("<font color=\"red\">CRITICAL:"
                         ." Critical connection failed: $server $cmd</font>");                          ." Critical connection failed: $server $cmd</font>");
                 &logperm("F:$server:$cmd");                  &logperm("F:$server:$cmd");
                 return 'con_failed';                  return 'con_failed';
Line 290  sub appenv { Line 291  sub appenv {
     my %newenv=@_;      my %newenv=@_;
     foreach (keys %newenv) {      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{$_}
                 .'</font>');                  .'</font>');
     delete($newenv{$_});      delete($newenv{$_});
Line 304  sub appenv { Line 305  sub appenv {
  return 'error: '.$!;   return 'error: '.$!;
     }      }
     unless (flock($lockfh,LOCK_EX)) {      unless (flock($lockfh,LOCK_EX)) {
          &logthis("<font color=blue>WARNING: ".           &logthis("<font color=\"blue\">WARNING: ".
                   'Could not obtain exclusive lock in appenv: '.$!);                    'Could not obtain exclusive lock in appenv: '.$!);
          close($lockfh);           close($lockfh);
          return 'error: '.$!;           return 'error: '.$!;
Line 349  sub delenv { Line 350  sub delenv {
     my $delthis=shift;      my $delthis=shift;
     my %newenv=();      my %newenv=();
     if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {      if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {
         &logthis("<font color=blue>WARNING: ".          &logthis("<font color=\"blue\">WARNING: ".
                 "Attempt to delete from environment ".$delthis);                  "Attempt to delete from environment ".$delthis);
         return 'error';          return 'error';
     }      }
Line 360  sub delenv { Line 361  sub delenv {
     return 'error';      return 'error';
  }   }
  unless (flock($fh,LOCK_SH)) {   unless (flock($fh,LOCK_SH)) {
     &logthis("<font color=blue>WARNING: ".      &logthis("<font color=\"blue\">WARNING: ".
      'Could not obtain shared lock in delenv: '.$!);       'Could not obtain shared lock in delenv: '.$!);
     close($fh);      close($fh);
     return 'error: '.$!;      return 'error: '.$!;
Line 374  sub delenv { Line 375  sub delenv {
     return 'error';      return 'error';
  }   }
  unless (flock($fh,LOCK_EX)) {   unless (flock($fh,LOCK_EX)) {
     &logthis("<font color=blue>WARNING: ".      &logthis("<font color=\"blue\">WARNING: ".
      'Could not obtain exclusive lock in delenv: '.$!);       'Could not obtain exclusive lock in delenv: '.$!);
     close($fh);      close($fh);
     return 'error: '.$!;      return 'error: '.$!;
Line 443  sub overloaderror { Line 444  sub overloaderror {
 # ------------------------------ Find server with least workload from spare.tab  # ------------------------------ Find server with least workload from spare.tab
   
 sub spareserver {  sub spareserver {
     my ($loadpercent,$userloadpercent) = @_;      my ($loadpercent,$userloadpercent,$want_server_name) = @_;
     my $tryserver;      my $tryserver;
     my $spareserver='';      my $spareserver='';
     if ($userloadpercent !~ /\d/) { $userloadpercent=0; }      if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
     my $lowestserver=$loadpercent > $userloadpercent?      my $lowestserver=$loadpercent > $userloadpercent?
              $loadpercent :  $userloadpercent;               $loadpercent :  $userloadpercent;
     foreach $tryserver (keys %spareid) {      foreach $tryserver (keys(%spareid)) {
  my $loadans=reply('load',$tryserver);   my $loadans=&reply('load',$tryserver);
  my $userloadans=reply('userload',$tryserver);   my $userloadans=&reply('userload',$tryserver);
  if ($loadans !~ /\d/ && $userloadans !~ /\d/) {   if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
     next; #didn't get a number from the server      next; #didn't get a number from the server
  }   }
Line 468  sub spareserver { Line 469  sub spareserver {
     $answer = $userloadans;      $answer = $userloadans;
  }   }
  if (($answer =~ /\d/) && ($answer<$lowestserver)) {   if (($answer =~ /\d/) && ($answer<$lowestserver)) {
     $spareserver="http://$hostname{$tryserver}";      if ($want_server_name) {
    $spareserver=$tryserver;
       } else {
    $spareserver="http://$hostname{$tryserver}";
       }
     $lowestserver=$answer;      $lowestserver=$answer;
  }   }
     }      }
Line 1060  sub repcopy { Line 1065  sub repcopy {
            if ($response->is_error()) {             if ($response->is_error()) {
        unlink($transname);         unlink($transname);
                my $message=$response->status_line;                 my $message=$response->status_line;
                &logthis("<font color=blue>WARNING:"                 &logthis("<font color=\"blue\">WARNING:"
                        ." LWP get: $message: $filename</font>");                         ." LWP get: $message: $filename</font>");
                return 'unavailable';                 return 'unavailable';
            } else {             } else {
Line 1070  sub repcopy { Line 1075  sub repcopy {
                   if ($mresponse->is_error()) {                    if ($mresponse->is_error()) {
       unlink($filename.'.meta');        unlink($filename.'.meta');
                       &logthis(                        &logthis(
                      "<font color=yellow>INFO: No metadata: $filename</font>");                       "<font color=\"yellow\">INFO: No metadata: $filename</font>");
                   }                    }
        }         }
                rename($transname,$filename);                 rename($transname,$filename);
Line 1176  sub process_coursefile { Line 1181  sub process_coursefile {
         $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,          $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
      $home);       $home);
     } else {      } else {
         my $fetchresult = '';  
         my $fpath = '';          my $fpath = '';
         my $fname = $file;          my $fname = $file;
         ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|);          ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|);
Line 1539  sub flushcourselogs { Line 1543  sub flushcourselogs {
         } else {          } else {
             &logthis('Failed to flush log buffer for '.$crsid);              &logthis('Failed to flush log buffer for '.$crsid);
             if (length($courselogs{$crsid})>40000) {              if (length($courselogs{$crsid})>40000) {
                &logthis("<font color=blue>WARNING: Buffer for ".$crsid.                 &logthis("<font color=\"blue\">WARNING: Buffer for ".$crsid.
                         " exceeded maximum size, deleting.</font>");                          " exceeded maximum size, deleting.</font>");
                delete $courselogs{$crsid};                 delete $courselogs{$crsid};
             }              }
Line 1862  sub dcmaildump { Line 1866  sub dcmaildump {
     foreach my $tryserver (keys(%libserv)) {      foreach my $tryserver (keys(%libserv)) {
         if ($hostdom{$tryserver} eq $dom) {          if ($hostdom{$tryserver} eq $dom) {
             %{$returnhash{$tryserver}}=();              %{$returnhash{$tryserver}}=();
             foreach (      my $cmd='dcmaildump:'.$dom.':'.
                 split(/\&/,&reply('dcmaildump:'.$dom.':'.   &escape($startdate).':'.&escape($enddate).':';
                    &escape($startdate).':'.&escape($enddate).':'.      my @esc_senders=map { &escape($_)} @$senders;
                    &escape($senders), $tryserver))) {      $cmd.=&escape(join('&',@esc_senders));
       foreach (split(/\&/,&reply($cmd,$tryserver))) {
                 my ($key,$value) = split(/\=/,$_);                  my ($key,$value) = split(/\=/,$_);
                 if (($key) && ($value)) {                  if (($key) && ($value)) {
                     $returnhash{$tryserver}{&unescape($key)} = &unescape($value);                      $returnhash{$tryserver}{&unescape($key)} = &unescape($value);
Line 1949  sub checkout { Line 1954  sub checkout {
  $now.'&'.$ENV{'REMOTE_ADDR'});   $now.'&'.$ENV{'REMOTE_ADDR'});
     my $token=&reply('tmpput:'.$infostr,$lonhost);      my $token=&reply('tmpput:'.$infostr,$lonhost);
     if ($token=~/^error\:/) {       if ($token=~/^error\:/) { 
         &logthis("<font color=blue>WARNING: ".          &logthis("<font color=\"blue\">WARNING: ".
                 "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.                  "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.
                  "</font>");                   "</font>");
         return '';           return ''; 
Line 1965  sub checkout { Line 1970  sub checkout {
     unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {      unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
        return '';         return '';
     } else {      } else {
         &logthis("<font color=blue>WARNING: ".          &logthis("<font color=\"blue\">WARNING: ".
                 "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.                  "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.
                  "</font>");                   "</font>");
     }          }    
Line 1975  sub checkout { Line 1980  sub checkout {
                                                  $token)) ne 'ok') {                                                   $token)) ne 'ok') {
  return '';   return '';
     } else {      } else {
         &logthis("<font color=blue>WARNING: ".          &logthis("<font color=\"blue\">WARNING: ".
                 "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.                  "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.
                  "</font>");                   "</font>");
     }      }
Line 2570  sub rolesinit { Line 2575  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 %allgroups=();   
     my $now=time;      my $now=time;
     my $userroles="user.login.time=$now\n";      my $userroles="user.login.time=$now\n";
       my $group_privs;
   
     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);              my ($trole,$tend,$tstart,$group_privs);
     if ($role=~/^cr/) {       if ($role=~/^cr/) { 
  if ($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|) {   if ($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|) {
     ($trole,my $trest)=($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|);      ($trole,my $trest)=($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|);
Line 2586  sub rolesinit { Line 2593  sub rolesinit {
  } else {   } else {
     $trole=$role;      $trole=$role;
  }   }
               } elsif ($role =~ m|^gr/|) {
                   ($trole,$tend,$tstart) = split(/_/,$role);
                   ($trole,$group_privs) = split(/\//,$trole);
                   $group_privs = &unescape($group_privs);
     } else {      } else {
  ($trole,$tend,$tstart)=split(/_/,$role);   ($trole,$tend,$tstart)=split(/_/,$role);
     }      }
Line 2597  sub rolesinit { Line 2608  sub rolesinit {
  my ($tdummy,$tdomain,$trest)=split(/\//,$area);   my ($tdummy,$tdomain,$trest)=split(/\//,$area);
  if ($trole =~ /^cr\//) {   if ($trole =~ /^cr\//) {
                     &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);                      &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
                   } elsif ($trole eq 'gr') {
                       &group_roleprivs(\%allgroups,$area,$group_privs,$tend,$tstart);
  } else {   } else {
                     &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);                      &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
  }   }
             }              }
           }            }
         }          }
         my ($author,$adv) = &set_userprivs(\$userroles,\%allroles);          my ($author,$adv) = &set_userprivs(\$userroles,\%allroles,\%allgroups);
         $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 2645  sub custom_roleprivs { Line 2658  sub custom_roleprivs {
     }      }
 }  }
   
   sub group_roleprivs {
       my ($allgroups,$area,$group_privs,$tend,$tstart) = @_;
       my $access = 1;
       my $now = time;
       if (($tend!=0) && ($tend<$now)) { $access = 0; }
       if (($tstart!=0) && ($tstart>$now)) { $access=0; }
       if ($access) {
           my ($course,$group) = ($area =~ m|(/\w+/\w+)/([^/]+)$|);
           $$allgroups{$course}{$group} .=':'.$group_privs;
       }
   }
   
 sub standard_roleprivs {  sub standard_roleprivs {
     my ($allroles,$trole,$tdomain,$spec,$trest,$area) = @_;      my ($allroles,$trole,$tdomain,$spec,$trest,$area) = @_;
Line 2665  sub standard_roleprivs { Line 2689  sub standard_roleprivs {
 }  }
   
 sub set_userprivs {  sub set_userprivs {
     my ($userroles,$allroles) = @_;       my ($userroles,$allroles,$allgroups) = @_; 
     my $author=0;      my $author=0;
     my $adv=0;      my $adv=0;
       my %grouproles = ();
       if (keys(%{$allgroups}) > 0) {
           foreach my $role (keys %{$allroles}) {
               my ($trole,$area,$sec,$extendedarea);
               if ($role =~ m|^(\w+)\.(/\w+/\w+)(/?\w*)|) {
                   $trole = $1;
                   $area = $2;
                   $sec = $3;
                   $extendedarea = $area.$sec;
                   if (exists($$allgroups{$area})) {
                       foreach my $group (keys(%{$$allgroups{$area}})) {
                           my $spec = $trole.'.'.$extendedarea;
                           $grouproles{$spec.'.'.$area.'/'.$group} = 
                                                   $$allgroups{$area}{$group};
                       }
                   }
               }
           }
       }
       foreach (keys(%grouproles)) {
           $$allroles{$_} = $grouproles{$_};
       }
     foreach (keys %{$allroles}) {      foreach (keys %{$allroles}) {
         my %thesepriv=();          my %thesepriv=();
         if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; }          if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; }
Line 2954  sub eget { Line 3000  sub eget {
    return %returnhash;     return %returnhash;
 }  }
   
   # ------------------------------------------------------------ tmpput interface
   sub tmpput {
       my ($storehash,$server)=@_;
       my $items='';
       foreach (keys(%$storehash)) {
    $items.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&';
       }
       $items=~s/\&$//;
       return &reply("tmpput:$items",$server);
   }
   
   # ------------------------------------------------------------ tmpget interface
   sub tmpget {
       my ($token)=@_;
       my $rep=&reply("tmpget:$token",$perlvar{'lonHostID'});
       my %returnhash;
       foreach my $item (split(/\&/,$rep)) {
    my ($key,$value)=split(/=/,$item);
    $returnhash{&unescape($key)}=&thaw_unescape($value);
       }
       return %returnhash;
   }
   
 # ---------------------------------------------- Custom access rule evaluation  # ---------------------------------------------- Custom access rule evaluation
   
 sub customaccess {  sub customaccess {
Line 2996  sub allowed { Line 3065  sub allowed {
     my $orguri=$uri;      my $orguri=$uri;
     $uri=&declutter($uri);      $uri=&declutter($uri);
           
       
       
     if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }      if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }
 # Free bre access to adm and meta resources  # Free bre access to adm and meta resources
     if (((($uri=~/^adm\//) && ($uri !~ m|/bulletinboard$|))       if (((($uri=~/^adm\//) && ($uri !~ m|/bulletinboard$|)) 
Line 3044  sub allowed { Line 3111  sub allowed {
     if (($priv eq 'ccc') && ($env{'request.role'} =~ /^dc\./)) {      if (($priv eq 'ccc') && ($env{'request.role'} =~ /^dc\./)) {
         # uri is the requested domain in this case.          # uri is the requested domain in this case.
         # comparison to 'request.role.domain' shows if the user has selected          # comparison to 'request.role.domain' shows if the user has selected
         # a role of dc for the domain in question.           # a role of dc for the domain in question.
         return 'F' if ($uri eq $env{'request.role.domain'});          return 'F' if ($uri eq $env{'request.role.domain'});
     }      }
   
Line 3075  sub allowed { Line 3142  sub allowed {
        $thisallowed.=$1;         $thisallowed.=$1;
     }      }
   
 # URI is an uploaded document for this course  # Group: uri itself is a group
       my $groupuri=$uri;
       $groupuri=~s/^([^\/])/\/$1/;
       if ($env{'user.priv.'.$env{'request.role'}.'.'.$groupuri}
          =~/\Q$priv\E\&([^\:]*)/) {
          $thisallowed.=$1;
       }
   
   # URI is an uploaded document for this course, default permissions don't matter
 # not allowing 'edit' access (editupload) to uploaded course docs  # not allowing 'edit' access (editupload) to uploaded course docs
     if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) {      if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) {
  my $refuri=$env{'httpref.'.$orguri};   $thisallowed='';
  if ($refuri) {          my ($match)=&is_on_map($uri);
     if ($refuri =~ m|^/adm/|) {          if ($match) {
  $thisallowed='F';              if ($env{'user.priv.'.$env{'request.role'}.'./'}
     }                    =~/\Q$priv\E\&([^\:]*)/) {
  }                  $thisallowed.=$1;
               }
           } else {
               my $refuri=$env{'httpref.'.$orguri};
               if ($refuri) {
                   if ($refuri =~ m|^/adm/|) {
                       $thisallowed='F';
                   } else {
                       $refuri=&declutter($refuri);
                       my ($match) = &is_on_map($refuri);
                       if ($match) {
                           $thisallowed='F';
                       }
                   }
               }
           }
     }      }
   
 # Full access at system, domain or course-wide level? Exit.  # Full access at system, domain or course-wide level? Exit.
Line 3251  sub allowed { Line 3341  sub allowed {
        my $unamedom=$env{'user.name'}.':'.$env{'user.domain'};         my $unamedom=$env{'user.name'}.':'.$env{'user.domain'};
        if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'}         if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'}
    =~/\Q$rolecode\E/) {     =~/\Q$rolecode\E/) {
            &log($env{'user.domain'},$env{'user.name'},$env{'user.host'},             &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
                 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.                  'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
                 $env{'request.course.id'});                  $env{'request.course.id'});
            return '';             return '';
Line 3259  sub allowed { Line 3349  sub allowed {
   
        if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'}         if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'}
    =~/\Q$unamedom\E/) {     =~/\Q$unamedom\E/) {
            &log($env{'user.domain'},$env{'user.name'},$env{'user.host'},             &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.
                 'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.                  'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.
                 $env{'request.course.id'});                  $env{'request.course.id'});
            return '';             return '';
Line 3271  sub allowed { Line 3361  sub allowed {
    if ($thisallowed=~/R/) {     if ($thisallowed=~/R/) {
        my $rolecode=(split(/\./,$env{'request.role'}))[0];         my $rolecode=(split(/\./,$env{'request.role'}))[0];
        if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) {         if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) {
   &log($env{'user.domain'},$env{'user.name'},$env{'user.host'},     &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
                     'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);   'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
           return '';            return '';
        }         }
    }     }
Line 3610  sub auto_instcode_format { Line 3700  sub auto_instcode_format {
     return $response;      return $response;
 }  }
   
   # ------------------------------------------------------- Course Group routines
   
   sub get_coursegroups {
       my ($cdom,$cnum,$curr_groups,$group) = @_;
       my $numgroups = 0;
       %{$curr_groups} = &dump('coursegroups',$cdom,$cnum,$group);
       my ($tmp)=keys(%{$curr_groups});
       if ($tmp eq 'error: 2 tie(GDBM) Failed while attempting dump') {
           my %emptyhash = ();
           if (&put('coursegroups',\%emptyhash,$cdom,$cnum) eq 'ok') {
               %{$curr_groups} = &dump('coursegroups',$cdom,$cnum,$group);
               $tmp=keys(%{$curr_groups});
           }
       }
       if ($tmp=~/^error:/) {
           &logthis('Error retrieving groups: '.$tmp.' in '.$cnum.':'.$cdom);
       } else {
           my @groups = keys(%{$curr_groups});
           $numgroups = @groups;
       }
       return $numgroups;
   }
   
   sub modify_coursegroup {
       my ($cdom,$cnum,$groupsettings) = @_;
       return(&put('coursegroups',$groupsettings,$cdom,$cnum));
   }
   
   sub modify_group_roles {
       my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs) = @_;
       my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;
       my $role = 'gr/'.&escape($userprivs);
       my ($uname,$udom) = split(/:/,$user);
       my $result = &assignrole($udom,$uname,$url,$role,$end,$start);
       return $result;
   }
   
   sub modify_coursegroup_membership {
       my ($cdom,$cnum,$membership) = @_;
       my $result = &put('groupmembership',$membership,$cdom,$cnum);
       return $result;
   }
   
   sub get_active_groups {
       my ($udom,$uname,$cdom,$cnum) = @_;
       my $now = time;
       my %groups = ();
       foreach my $key (keys(%env)) {
           if ($key =~ m-user\.role\.gr\./([^/]+)/([^/]+)/(\w+)$-) {
               my ($start,$end) = split(/\./,$env{$key});
               if (($end!=0) && ($end<$now)) { next; }
               if (($start!=0) && ($start>$now)) { next; }
               if ($1 eq $cdom && $2 eq $cnum) {
                   $groups{$3} = $env{$key} ;
               }
           }
       }
       return %groups;
   }
   
 # ------------------------------------------------------------------ Plain Text  # ------------------------------------------------------------------ Plain Text
   
 sub plaintext {  sub plaintext {
     my $short=shift;      my $short=shift;
     return &mt($prp{$short});      return &Apache::lonlocal::mt($prp{$short});
 }  }
   
 # ----------------------------------------------------------------- Assign Role  # ----------------------------------------------------------------- Assign Role
Line 3632  sub assignrole { Line 3782  sub assignrole {
            return 'refused';              return 'refused'; 
         }          }
         $mrole='cr';          $mrole='cr';
       } elsif ($role =~ /^gr\//) {
           my $cwogrp=$url;
           $cwogrp=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
           unless (&allowed('mdg',$cwogrp)) {
               &logthis('Refused group assignrole: '.
                 $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
                       $env{'user.name'}.' at '.$env{'user.domain'});
               return 'refused';
           }
           $mrole='gr';
     } else {      } else {
         my $cwosec=$url;          my $cwosec=$url;
         $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;          $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
Line 3792  sub modifyuser { Line 3952  sub modifyuser {
     }      }
     my $reply = &put('environment', \%names, $udom,$uname);      my $reply = &put('environment', \%names, $udom,$uname);
     if ($reply ne 'ok') { return 'error: '.$reply; }      if ($reply ne 'ok') { return 'error: '.$reply; }
       &devalidate_cache_new('namescache',$uname.':'.$udom);
     &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.      &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
              $umode.', '.$first.', '.$middle.', '.               $umode.', '.$first.', '.$middle.', '.
      $last.', '.$gene.' by '.       $last.', '.$gene.' by '.
Line 3932  sub createcourse { Line 4093  sub createcourse {
         return 'refused';          return 'refused';
     }      }
 # ------------------------------------------------------------------- Create ID  # ------------------------------------------------------------------- Create ID
    my $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).     my $uname=int(1+rand(9)).
          ('a'..'z','A'..'Z','0'..'9')[int(rand(62))].
          substr($$.time,0,5).unpack("H8",pack("I32",time)).
        unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};         unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
 # ----------------------------------------------- Make sure that does not exist  # ----------------------------------------------- Make sure that does not exist
    my $uhome=&homeserver($uname,$udom,'true');     my $uhome=&homeserver($uname,$udom,'true');
Line 4440  sub get_userresdata { Line 4603  sub get_userresdata {
     }      }
     #error 2 occurs when the .db doesn't exist      #error 2 occurs when the .db doesn't exist
     if ($tmp!~/error: 2 /) {      if ($tmp!~/error: 2 /) {
  &logthis("<font color=blue>WARNING:".   &logthis("<font color=\"blue\">WARNING:".
  " Trying to get resource data for ".   " Trying to get resource data for ".
  $uname." at ".$udom.": ".   $uname." at ".$udom.": ".
  $tmp."</font>");   $tmp."</font>");
Line 4594  sub EXT { Line 4757  sub EXT {
 # ------------------------------------------------------------- request.browser  # ------------------------------------------------------------- request.browser
         if ($space eq 'browser') {          if ($space eq 'browser') {
     if ($qualifier eq 'textremote') {      if ($qualifier eq 'textremote') {
  if (&mt('textual_remote_display') eq 'on') {   if (&Apache::lonlocal::mt('textual_remote_display') eq 'on') {
     return 1;      return 1;
  } else {   } else {
     return 0;      return 0;
Line 5335  sub numval3 { Line 5498  sub numval3 {
     return $total;      return $total;
 }  }
   
   sub digest {
       my ($data)=@_;
       my $digest=&Digest::MD5::md5($data);
       my ($a,$b,$c,$d)=unpack("iiii",$digest);
       my ($e,$f);
       {
           use integer;
           $e=($a+$b);
           $f=($c+$d);
           if ($_64bit) {
               $e=(($e<<32)>>32);
               $f=(($f<<32)>>32);
           }
       }
       if (wantarray) {
    return ($e,$f);
       } else {
    my $g;
    {
       use integer;
       $g=($e+$f);
       if ($_64bit) {
    $g=(($g<<32)>>32);
       }
    }
    return $g;
       }
   }
   
 sub latest_rnd_algorithm_id {  sub latest_rnd_algorithm_id {
     return '64bit4';      return '64bit5';
 }  }
   
 sub get_rand_alg {  sub get_rand_alg {
Line 5376  sub rndseed { Line 5568  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())) {
  if ($which eq '64bit4') {   if ($which eq '64bit5') {
       return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username);
    } elsif ($which eq '64bit4') {
     return &rndseed_CODE_64bit4($symb,$courseid,$domain,$username);      return &rndseed_CODE_64bit4($symb,$courseid,$domain,$username);
  } else {   } else {
     return &rndseed_CODE_64bit($symb,$courseid,$domain,$username);      return &rndseed_CODE_64bit($symb,$courseid,$domain,$username);
  }   }
       } elsif ($which eq '64bit5') {
    return &rndseed_64bit5($symb,$courseid,$domain,$username);
     } elsif ($which eq '64bit4') {      } elsif ($which eq '64bit4') {
  return &rndseed_64bit4($symb,$courseid,$domain,$username);   return &rndseed_64bit4($symb,$courseid,$domain,$username);
     } elsif ($which eq '64bit3') {      } elsif ($which eq '64bit3') {
Line 5503  sub rndseed_64bit4 { Line 5699  sub rndseed_64bit4 {
     }      }
 }  }
   
   sub rndseed_64bit5 {
       my ($symb,$courseid,$domain,$username)=@_;
       my ($num1,$num2)=&digest("$symb,$courseid,$domain,$username");
       return "$num1:$num2";
   }
   
 sub rndseed_CODE_64bit {  sub rndseed_CODE_64bit {
     my ($symb,$courseid,$domain,$username)=@_;      my ($symb,$courseid,$domain,$username)=@_;
     {      {
Line 5541  sub rndseed_CODE_64bit4 { Line 5743  sub rndseed_CODE_64bit4 {
     }      }
 }  }
   
   sub rndseed_CODE_64bit5 {
       my ($symb,$courseid,$domain,$username)=@_;
       my $code = &getCODE();
       my ($num1,$num2)=&digest("$symb,$courseid,$code");
       return "$num1:$num2";
   }
   
 sub setup_random_from_rndseed {  sub setup_random_from_rndseed {
     my ($rndseed)=@_;      my ($rndseed)=@_;
     if ($rndseed =~/([,:])/) {      if ($rndseed =~/([,:])/) {
Line 5785  sub filelocation { Line 5994  sub filelocation {
 sub hreflocation {  sub hreflocation {
     my ($dir,$file)=@_;      my ($dir,$file)=@_;
     unless (($file=~m-^http://-i) || ($file=~m-^/-)) {      unless (($file=~m-^http://-i) || ($file=~m-^/-)) {
  my $finalpath=filelocation($dir,$file);   $file=filelocation($dir,$file);
  $finalpath=~s-^/home/httpd/html--;      }
  $finalpath=~s-^/home/(\w+)/public_html/-/~$1/-;      if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) {
  return $finalpath;   $file=~s-^\Q$perlvar{'lonDocRoot'}\E--;
     } elsif ($file=~m-^/home-) {      } elsif ($file=~m-/home/(\w+)/public_html/-) {
  $file=~s-^/home/httpd/html--;  
  $file=~s-^/home/(\w+)/public_html/-/~$1/-;   $file=~s-^/home/(\w+)/public_html/-/~$1/-;
  return $file;      } elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) {
    $file=~s-^/home/httpd/lonUsers/([^/]*)/./././([^/]*)/userfiles/
       -/uploaded/$1/$2/-x;
     }      }
     return $file;      return $file;
 }  }
Line 5878  sub thaw_unescape { Line 6088  sub thaw_unescape {
     return &unescape($value);      return &unescape($value);
 }  }
   
 sub mod_perl_version {  
     return 1;  
     if (defined($perlvar{'MODPERL2'})) {  
  return 2;  
     }  
 }  
   
 sub correct_line_ends {  sub correct_line_ends {
     my ($result)=@_;      my ($result)=@_;
     $$result =~s/\r\n/\n/mg;      $$result =~s/\r\n/\n/mg;
Line 6083  $processmarker='_'.time.'_'.$perlvar{'lo Line 6286  $processmarker='_'.time.'_'.$perlvar{'lo
 $dumpcount=0;  $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;   use integer;
Removed from v.1.663  
changed lines
  Added in v.1.682

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