[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.806 and 1.807

version 1.806, 2006/11/21 20:58:06 version 1.807, 2006/11/22 19:59:42
Line 54  use Cache::Memcached; Line 54  use Cache::Memcached;
 use Digest::MD5;  use Digest::MD5;
 use Math::Random;  use Math::Random;
 use lib '/home/httpd/lib/perl';  use lib '/home/httpd/lib/perl';
 use LONCAPA;  use LONCAPA qw(:DEFAULT :match);
 use LONCAPA::Configuration;  use LONCAPA::Configuration;
   
 my $readit;  my $readit;
Line 190  sub subreply { Line 190  sub subreply {
   
 sub reply {  sub reply {
     my ($cmd,$server)=@_;      my ($cmd,$server)=@_;
       &logthis("$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=~/^refused/) || ($answer=~/^rejected/)) {      if (($answer=~/^refused/) || ($answer=~/^rejected/)) {
Line 588  sub queryauthenticate { Line 589  sub queryauthenticate {
   
 sub authenticate {  sub authenticate {
     my ($uname,$upass,$udom)=@_;      my ($uname,$upass,$udom)=@_;
     $upass=escape($upass);      $upass=&escape($upass);
     $uname=~s/\W//g;      $uname= &LONCAPA::clean_username($uname);
     my $uhome=&homeserver($uname,$udom);      my $uhome=&homeserver($uname,$udom);
     if (!$uhome) {      if (!$uhome) {
  &logthis("User $uname at $udom is unknown in authenticate");   &logthis("User $uname at $udom is unknown in authenticate");
Line 874  sub validate_access_key { Line 875  sub validate_access_key {
 # ------------------------------------- Find the section of student in a course  # ------------------------------------- Find the section of student in a course
 sub devalidate_getsection_cache {  sub devalidate_getsection_cache {
     my ($udom,$unam,$courseid)=@_;      my ($udom,$unam,$courseid)=@_;
     $courseid=~s/\_/\//g;  
     $courseid=~s/^(\w)/\/$1/;  
     my $hashid="$udom:$unam:$courseid";      my $hashid="$udom:$unam:$courseid";
     &devalidate_cache_new('getsection',$hashid);      &devalidate_cache_new('getsection',$hashid);
 }  }
Line 883  sub devalidate_getsection_cache { Line 882  sub devalidate_getsection_cache {
 sub getsection {  sub getsection {
     my ($udom,$unam,$courseid)=@_;      my ($udom,$unam,$courseid)=@_;
     my $cachetime=1800;      my $cachetime=1800;
     $courseid=~s/\_/\//g;  
     $courseid=~s/^(\w)/\/$1/;  
   
     my $hashid="$udom:$unam:$courseid";      my $hashid="$udom:$unam:$courseid";
     my ($result,$cached)=&is_cached_new('getsection',$hashid);      my ($result,$cached)=&is_cached_new('getsection',$hashid);
Line 1775  sub flushcourselogs { Line 1772  sub flushcourselogs {
     foreach my $entry (keys(%accesshash)) {      foreach my $entry (keys(%accesshash)) {
         if ($entry =~ /___count$/) {          if ($entry =~ /___count$/) {
             my ($dom,$name);              my ($dom,$name);
             ($dom,$name,undef)=($entry=~m:___(\w+)/(\w+)/(.*)___count$:);              ($dom,$name,undef)=
    ($entry=~m{___($match_domain)/($match_username)/(.*)___count$});
             if (! defined($dom) || $dom eq '' ||               if (! defined($dom) || $dom eq '' || 
                 ! defined($name) || $name eq '') {                  ! defined($name) || $name eq '') {
                 my $cid = $env{'request.course.id'};                  my $cid = $env{'request.course.id'};
Line 1796  sub flushcourselogs { Line 1794  sub flushcourselogs {
                 }                  }
             }              }
         } else {          } else {
             my ($dom,$name) = ($entry=~m:___(\w+)/(\w+)/(.*)___(\w+)$:);              my ($dom,$name) = ($entry=~m{___($match_domain)/($match_username)/(.*)___(\w+)$});
             my %temphash=($entry => $accesshash{$entry});              my %temphash=($entry => $accesshash{$entry});
             if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {              if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {
                 delete $accesshash{$entry};                  delete $accesshash{$entry};
Line 2810  sub rolesinit { Line 2808  sub rolesinit {
     $area=~s/\_\w\w$//;      $area=~s/\_\w\w$//;
             my ($trole,$tend,$tstart,$group_privs);              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/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|) {
     ($trole,my $trest)=($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|);      ($trole,my $trest)=($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|);
     ($tend,$tstart)=split('_',$trest);      ($tend,$tstart)=split('_',$trest);
  } else {   } else {
     $trole=$role;      $trole=$role;
Line 2890  sub group_roleprivs { Line 2888  sub group_roleprivs {
     if (($tend!=0) && ($tend<$now)) { $access = 0; }      if (($tend!=0) && ($tend<$now)) { $access = 0; }
     if (($tstart!=0) && ($tstart>$now)) { $access=0; }      if (($tstart!=0) && ($tstart>$now)) { $access=0; }
     if ($access) {      if ($access) {
         my ($course,$group) = ($area =~ m|(/\w+/\w+)/([^/]+)$|);          my ($course,$group) = ($area =~ m|(/$match_domain/$match_username)/([^/]+)$|);
         $$allgroups{$course}{$group} .=':'.$group_privs;          $$allgroups{$course}{$group} .=':'.$group_privs;
     }      }
 }  }
Line 2921  sub set_userprivs { Line 2919  sub set_userprivs {
     if (keys(%{$allgroups}) > 0) {      if (keys(%{$allgroups}) > 0) {
         foreach my $role (keys %{$allroles}) {          foreach my $role (keys %{$allroles}) {
             my ($trole,$area,$sec,$extendedarea);              my ($trole,$area,$sec,$extendedarea);
             if ($role =~ m-^(\w+|cr/\w+/\w+/\w+)\.(/\w+/\w+)(/?\w*)-) {              if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_username)(/?\w*)-) {
                 $trole = $1;                  $trole = $1;
                 $area = $2;                  $area = $2;
                 $sec = $3;                  $sec = $3;
Line 3379  sub get_portfolio_access { Line 3377  sub get_portfolio_access {
                 my (%allgroups,%allroles);                   my (%allgroups,%allroles); 
                 my ($start,$end,$role,$sec,$group);                  my ($start,$end,$role,$sec,$group);
                 foreach my $envkey (%env) {                  foreach my $envkey (%env) {
                     if ($envkey =~ m-^user\.role\.(gr|cc|in|ta|ep|st)\./([^/]+)/([^/]+)/?([^/]*)$-) {                      if ($envkey =~ m-^user\.role\.(gr|cc|in|ta|ep|st)\./($match_domain)/($match_username)/?([^/]*)$-) {
                         my $cid = $2.'_'.$3;                           my $cid = $2.'_'.$3; 
                         if ($1 eq 'gr') {                          if ($1 eq 'gr') {
                             $group = $4;                              $group = $4;
Line 3392  sub get_portfolio_access { Line 3390  sub get_portfolio_access {
                             }                              }
                             $allroles{$cid}{$1}{$sec} = $env{$envkey};                              $allroles{$cid}{$1}{$sec} = $env{$envkey};
                         }                          }
                     } elsif ($envkey =~ m-^user\.role\./cr/(\w+/\w+/\w*)./([^/]+)/([^/]+)/?([^/]*)$-) {                      } elsif ($envkey =~ m-^user\.role\./cr/($match_domain/$match_username/\w*)./($match_domain)/($match_username)/?([^/]*)$-) {
                         my $cid = $2.'_'.$3;                          my $cid = $2.'_'.$3;
                         if ($4 eq '') {                          if ($4 eq '') {
                             $sec = 'none';                              $sec = 'none';
Line 3487  sub parse_portfolio_url { Line 3485  sub parse_portfolio_url {
   
     my ($type,$udom,$unum,$group,$file_name);      my ($type,$udom,$unum,$group,$file_name);
           
     if ($url =~  m-^/*uploaded/([^/]+)/([^/]+)/portfolio(/.+)$-) {      if ($url =~  m-^/*uploaded/($match_domain)/($match_username)/portfolio(/.+)$-) {
  $type = 1;   $type = 1;
         $udom = $1;          $udom = $1;
         $unum = $2;          $unum = $2;
         $file_name = $3;          $file_name = $3;
     } elsif ($url =~ m-^/*uploaded/([^/]+)/([^/]+)/groups/([^/]+)/portfolio/(.+)$-) {      } elsif ($url =~ m-^/*uploaded/($match_domain)/($match_username)/groups/([^/]+)/portfolio/(.+)$-) {
  $type = 2;   $type = 2;
         $udom = $1;          $udom = $1;
         $unum = $2;          $unum = $2;
Line 3512  sub is_portfolio_url { Line 3510  sub is_portfolio_url {
   
 sub is_portfolio_file {  sub is_portfolio_file {
     my ($file) = @_;      my ($file) = @_;
     if (($file =~ /^portfolio/) || ($file =~ /^groups\/\w+\/portfolio/)) {      if (($file =~ /^portfolio/) || ($file =~ /^groups\/$match_username\/portfolio/)) {
         return 1;          return 1;
     }      }
     return;      return;
Line 3523  sub is_portfolio_file { Line 3521  sub is_portfolio_file {
   
 sub customaccess {  sub customaccess {
     my ($priv,$uri)=@_;      my ($priv,$uri)=@_;
     my ($urole,$urealm)=split(/\./,$env{'request.role'});      my ($urole,$urealm)=split(/\./,$env{'request.role'},2);
     $urealm=~s/^\W//;  
     my ($udom,$ucrs,$usec)=split(/\//,$urealm);      my ($udom,$ucrs,$usec)=split(/\//,$urealm);
       $udom = &LONCAPA::clean_domain($udom);
       $ucrs = &LONCAPA::clean_username($ucrs);
     my $access=0;      my $access=0;
     foreach my $right (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) {      foreach my $right (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) {
  my ($effect,$realm,$role)=split(/\:/,$right);   my ($effect,$realm,$role)=split(/\:/,$right);
Line 4427  sub get_active_groups { Line 4426  sub get_active_groups {
     my $now = time;      my $now = time;
     my %groups = ();      my %groups = ();
     foreach my $key (keys(%env)) {      foreach my $key (keys(%env)) {
         if ($key =~ m-user\.role\.gr\./([^/]+)/([^/]+)/(\w+)$-) {          if ($key =~ m-user\.role\.gr\./($match_domain)/($match_username)/(\w+)$-) {
             my ($start,$end) = split(/\./,$env{$key});              my ($start,$end) = split(/\./,$env{$key});
             if (($end!=0) && ($end<$now)) { next; }              if (($end!=0) && ($end<$now)) { next; }
             if (($start!=0) && ($start>$now)) { next; }              if (($start!=0) && ($start>$now)) { next; }
Line 4448  sub get_users_groups { Line 4447  sub get_users_groups {
     my ($udom,$uname,$courseid) = @_;      my ($udom,$uname,$courseid) = @_;
     my @usersgroups;      my @usersgroups;
     my $cachetime=1800;      my $cachetime=1800;
     $courseid=~s/\_/\//g;  
     $courseid=~s/^(\w)/\/$1/;  
   
     my $hashid="$udom:$uname:$courseid";      my $hashid="$udom:$uname:$courseid";
     my ($grouplist,$cached)=&is_cached_new('getgroups',$hashid);      my ($grouplist,$cached)=&is_cached_new('getgroups',$hashid);
Line 4496  sub get_users_groups { Line 4493  sub get_users_groups {
 sub devalidate_getgroups_cache {  sub devalidate_getgroups_cache {
     my ($udom,$uname,$cdom,$cnum)=@_;      my ($udom,$uname,$cdom,$cnum)=@_;
     my $courseid = $cdom.'_'.$cnum;      my $courseid = $cdom.'_'.$cnum;
     $courseid=~s/\_/\//g;  
     $courseid=~s/^(\w)/\/$1/;  
     my $hashid="$udom:$uname:$courseid";      my $hashid="$udom:$uname:$courseid";
     &devalidate_cache_new('getgroups',$hashid);      &devalidate_cache_new('getgroups',$hashid);
 }  }
Line 4536  sub assignrole { Line 4532  sub assignrole {
     my $mrole;      my $mrole;
     if ($role =~ /^cr\//) {      if ($role =~ /^cr\//) {
         my $cwosec=$url;          my $cwosec=$url;
         $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;          $cwosec=~s/^\/($match_domain)\/($match_username)\/.*/$1\/$2/;
  unless (&allowed('ccr',$cwosec)) {   unless (&allowed('ccr',$cwosec)) {
            &logthis('Refused custom assignrole: '.             &logthis('Refused custom assignrole: '.
              $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.               $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
Line 4546  sub assignrole { Line 4542  sub assignrole {
         $mrole='cr';          $mrole='cr';
     } elsif ($role =~ /^gr\//) {      } elsif ($role =~ /^gr\//) {
         my $cwogrp=$url;          my $cwogrp=$url;
         $cwogrp=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;          $cwogrp=~s{^/($match_domain)/($match_username)/.*}
                     {$1/$2}x;
         unless (&allowed('mdg',$cwogrp)) {          unless (&allowed('mdg',$cwogrp)) {
             &logthis('Refused group assignrole: '.              &logthis('Refused group assignrole: '.
               $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.                $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
Line 4556  sub assignrole { Line 4553  sub assignrole {
         $mrole='gr';          $mrole='gr';
     } else {      } else {
         my $cwosec=$url;          my $cwosec=$url;
         $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;          $cwosec=~s/^\/($match_domain)\/($match_username)\/.*/$1\/$2/;
         unless ((&allowed('c'.$role,$cwosec)) || &allowed('c'.$role,$udom)) {           unless ((&allowed('c'.$role,$cwosec)) || &allowed('c'.$role,$udom)) { 
            &logthis('Refused assignrole: '.             &logthis('Refused assignrole: '.
              $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.               $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
Line 4636  sub modifyuser { Line 4633  sub modifyuser {
         $umode,   $upass, $first,          $umode,   $upass, $first,
         $middle,  $last,  $gene,          $middle,  $last,  $gene,
         $forceid, $desiredhome, $email)=@_;          $forceid, $desiredhome, $email)=@_;
     $udom=~s/\W//g;      $udom= &LONCAPA::clean_domain($udom);
     $uname=~s/\W//g;      $uname=&LONCAPA::clean_username($uname);
     &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.      &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
              $umode.', '.$first.', '.$middle.', '.               $umode.', '.$first.', '.$middle.', '.
      $last.', '.$gene.'(forceid: '.$forceid.')'.       $last.', '.$gene.'(forceid: '.$forceid.')'.
Line 5411  sub dirlist { Line 5408  sub dirlist {
 ##  ##
 sub GetFileTimestamp {  sub GetFileTimestamp {
     my ($studentDomain,$studentName,$filename,$root)=@_;      my ($studentDomain,$studentName,$filename,$root)=@_;
     $studentDomain=~s/\W//g;      $studentDomain = &LONCAPA::clean_domain($studentDomain);
     $studentName=~s/\W//g;      $studentName   = &LONCAPA::clean_username($studentName);
     my $subdir=$studentName.'__';      my $subdir=$studentName.'__';
     $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;      $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
     my $proname="$studentDomain/$subdir/$studentName";      my $proname="$studentDomain/$subdir/$studentName";
Line 5435  sub stat_file { Line 5432  sub stat_file {
     my ($udom,$uname,$file,$dir);      my ($udom,$uname,$file,$dir);
     if ($uri =~ m-^/(uploaded|editupload)/-) {      if ($uri =~ m-^/(uploaded|editupload)/-) {
  ($udom,$uname,$file) =   ($udom,$uname,$file) =
     ($uri =~ m-/(?:uploaded|editupload)/?([^/]*)/?([^/]*)/?(.*)-);      ($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_username)/?(.*)-);
  $file = 'userfiles/'.$file;   $file = 'userfiles/'.$file;
  $dir = &propath($udom,$uname);   $dir = &propath($udom,$uname);
     }      }
     if ($uri =~ m-^/res/-) {      if ($uri =~ m-^/res/-) {
  ($udom,$uname) =    ($udom,$uname) = 
     ($uri =~ m-/(?:res)/?([^/]*)/?([^/]*)/-);      ($uri =~ m-/(?:res)/?($match_domain)/?($match_username)/-);
  $file = $uri;   $file = $uri;
     }      }
   
Line 6022  sub metadata { Line 6019  sub metadata {
  (($uri =~ m|^/*adm/|) &&    (($uri =~ m|^/*adm/|) && 
      ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) ||       ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) ||
         ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||          ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||
  ($uri =~ m|home/[^/]+/public_html/|)) {   ($uri =~ m|home/$match_username/public_html/|)) {
  return undef;   return undef;
     }      }
     my $filename=$uri;      my $filename=$uri;
Line 7000  sub repcopy_userfile { Line 6997  sub repcopy_userfile {
     if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); }      if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); }
     if ($file =~ m|^/home/httpd/html/lonUsers/|) { return 'ok'; }      if ($file =~ m|^/home/httpd/html/lonUsers/|) { return 'ok'; }
     my ($cdom,$cnum,$filename) =       my ($cdom,$cnum,$filename) = 
  ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+([^/]+)/+([^/]+)/+(.*)|);   ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_username)/+(.*)|);
     my ($info,$rtncode);      my ($info,$rtncode);
     my $uri="/uploaded/$cdom/$cnum/$filename";      my $uri="/uploaded/$cdom/$cnum/$filename";
     if (-e "$file") {      if (-e "$file") {
Line 7117  sub filelocation { Line 7114  sub filelocation {
     if ($file=~m:^/~:) { # is a contruction space reference      if ($file=~m:^/~:) { # is a contruction space reference
         $location = $file;          $location = $file;
         $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;          $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;
     } elsif ($file=~m:^/home/[^/]*/public_html/:) {      } elsif ($file=~m{^/home/$match_username/public_html/}) {
  # is a correct contruction space reference   # is a correct contruction space reference
         $location = $file;          $location = $file;
     } elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file      } elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file
         my ($udom,$uname,$filename)=          my ($udom,$uname,$filename)=
      ($file=~m -^/+(?:uploaded|editupload)/+([^/]+)/+([^/]+)/+(.*)$-);       ($file=~m -^/+(?:uploaded|editupload)/+($match_domain)/+($match_username)/+(.*)$-);
         my $home=&homeserver($uname,$udom);          my $home=&homeserver($uname,$udom);
         my $is_me=0;          my $is_me=0;
         my @ids=&current_machine_ids();          my @ids=&current_machine_ids();
Line 7159  sub hreflocation { Line 7156  sub hreflocation {
     }      }
     if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) {      if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) {
  $file=~s-^\Q$perlvar{'lonDocRoot'}\E--;   $file=~s-^\Q$perlvar{'lonDocRoot'}\E--;
     } elsif ($file=~m-/home/(\w+)/public_html/-) {      } elsif ($file=~m-/home/($match_username)/public_html/-) {
  $file=~s-^/home/(\w+)/public_html/-/~$1/-;   $file=~s-^/home/($match_username)/public_html/-/~$1/-;
     } elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) {      } elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) {
  $file=~s-^/home/httpd/lonUsers/([^/]*)/./././([^/]*)/userfiles/   $file=~s-^/home/httpd/lonUsers/($match_domain)/./././($match_username)/userfiles/
     -/uploaded/$1/$2/-x;      -/uploaded/$1/$2/-x;
     }      }
     return $file;      return $file;
Removed from v.1.806  
changed lines
  Added in v.1.807

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