[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.814

version 1.806, 2006/11/21 20:58:06 version 1.814, 2006/12/11 14:06:05
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 588  sub queryauthenticate { Line 588  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 874  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 881  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 1771  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_name)/(.*)___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 1793  sub flushcourselogs {
                 }                  }
             }              }
         } else {          } else {
             my ($dom,$name) = ($entry=~m:___(\w+)/(\w+)/(.*)___(\w+)$:);              my ($dom,$name) = ($entry=~m{___($match_domain)/($match_name)/(.*)___(\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 2735  sub coursedescription { Line 2732  sub coursedescription {
     if (!$args->{'one_time'}) {      if (!$args->{'one_time'}) {
  $envhash{'course.'.$normalid.'.last_cache'}=time;   $envhash{'course.'.$normalid.'.last_cache'}=time;
     }      }
   
     if ($chome ne 'no_host') {      if ($chome ne 'no_host') {
        %returnhash=&dump('environment',$cdomain,$cnum);         %returnhash=&dump('environment',$cdomain,$cnum);
        if (!exists($returnhash{'con_lost'})) {         if (!exists($returnhash{'con_lost'})) {
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_courseid)/([^/]+)$|);
         $$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_courseid)(/?\w*)-) {
                 $trole = $1;                  $trole = $1;
                 $area = $2;                  $area = $2;
                 $sec = $3;                  $sec = $3;
Line 3046  sub getkeys { Line 3044  sub getkeys {
    my $rep=reply("keys:$udomain:$uname:$namespace",$uhome);     my $rep=reply("keys:$udomain:$uname:$namespace",$uhome);
    my @keyarray=();     my @keyarray=();
    foreach my $key (split(/\&/,$rep)) {     foreach my $key (split(/\&/,$rep)) {
         next if ($key =~ /^error: 2 /);
       push(@keyarray,&unescape($key));        push(@keyarray,&unescape($key));
    }     }
    return @keyarray;     return @keyarray;
Line 3304  sub portfolio_access { Line 3303  sub portfolio_access {
     my ($requrl) = @_;      my ($requrl) = @_;
     my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl);      my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl);
     my $result = &get_portfolio_access($udom,$unum,$file_name,$group);      my $result = &get_portfolio_access($udom,$unum,$file_name,$group);
       if ($result) {
           my %setters;
           if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
               my ($startblock,$endblock) =
                   &Apache::loncommon::blockcheck(\%setters,'port',$unum,$udom);
               if ($startblock && $endblock) {
                   return 'B';
               }
           } else {
               my ($startblock,$endblock) =
                   &Apache::loncommon::blockcheck(\%setters,'port');
               if ($startblock && $endblock) {
                   return 'B';
               }
           }
       }
     if ($result eq 'ok') {      if ($result eq 'ok') {
        return 'F';         return 'F';
     } elsif ($result =~ /^[^:]+:guest_/) {      } elsif ($result =~ /^[^:]+:guest_/) {
Line 3379  sub get_portfolio_access { Line 3394  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_courseid)/?([^/]*)$-) {
                         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 3407  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_courseid)/?([^/]*)$-) {
                         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 3502  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_courseid)/groups/([^/]+)/portfolio/(.+)$-) {
  $type = 2;   $type = 2;
         $udom = $1;          $udom = $1;
         $unum = $2;          $unum = $2;
Line 3512  sub is_portfolio_url { Line 3527  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\/\w\/portfolio/)) {
         return 1;          return 1;
     }      }
     return;      return;
Line 3523  sub is_portfolio_file { Line 3538  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 3556  sub customaccess { Line 3572  sub customaccess {
 # ------------------------------------------------- Check for a user privilege  # ------------------------------------------------- Check for a user privilege
   
 sub allowed {  sub allowed {
     my ($priv,$uri,$symb)=@_;      my ($priv,$uri,$symb,$role)=@_;
     my $ver_orguri=$uri;      my $ver_orguri=$uri;
     $uri=&deversion($uri);      $uri=&deversion($uri);
     my $orguri=$uri;      my $orguri=$uri;
     $uri=&declutter($uri);      $uri=&declutter($uri);
       
       if ($priv eq 'evb') {
   # Evade communication block restrictions for specified role in a course
           if ($env{'user.priv.'.$role} =~/evb\&([^\:]*)/) {
               return $1;
           } else {
               return;
           }
       }
   
     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{/(?:smppg|bulletinboard)$}))       if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard)$})) 
Line 3574  sub allowed { Line 3599  sub allowed {
     my ($space,$domain,$name,@dir)=split('/',$uri);      my ($space,$domain,$name,@dir)=split('/',$uri);
     if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) &&       if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) && 
  ($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) {   ($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) {
         return 'F';          my %setters;
           my ($startblock,$endblock) = 
               &Apache::loncommon::blockcheck(\%setters,'port');
           if ($startblock && $endblock) {
               return 'B';
           } else {
               return 'F';
           }
     }      }
   
 # bre access to group portfolio for rgf priv in group, or mdg or vcg in course.  # bre access to group portfolio for rgf priv in group, or mdg or vcg in course.
Line 3850  sub allowed { Line 3882  sub allowed {
     unless ($env{'request.course.id'}) {      unless ($env{'request.course.id'}) {
  if ($thisallowed eq 'A') {   if ($thisallowed eq 'A') {
     return 'A';      return 'A';
           } elsif ($thisallowed eq 'B') {
               return 'B';
  } else {   } else {
     return '1';      return '1';
  }   }
Line 3917  sub allowed { Line 3951  sub allowed {
   
     if ($thisallowed eq 'A') {      if ($thisallowed eq 'A') {
  return 'A';   return 'A';
       } elsif ($thisallowed eq 'B') {
           return 'B';
     }      }
    return 'F';     return 'F';
 }  }
Line 4367  sub auto_validate_class_sec { Line 4403  sub auto_validate_class_sec {
 # ------------------------------------------------------- Course Group routines  # ------------------------------------------------------- Course Group routines
   
 sub get_coursegroups {  sub get_coursegroups {
     my ($cdom,$cnum,$group) = @_;      my ($cdom,$cnum,$group,$namespace) = @_;
     return(&dump('coursegroups',$cdom,$cnum,$group));      return(&dump($namespace,$cdom,$cnum,$group));
 }  
   
 sub get_deleted_groups {  
     my ($cdom,$cnum,$group) = @_;  
     return(&dump('deleted_groups',$cdom,$cnum,$group));  
 }  }
   
 sub modify_coursegroup {  sub modify_coursegroup {
Line 4381  sub modify_coursegroup { Line 4412  sub modify_coursegroup {
     return(&put('coursegroups',$groupsettings,$cdom,$cnum));      return(&put('coursegroups',$groupsettings,$cdom,$cnum));
 }  }
   
 sub delete_coursegroup {  sub toggle_coursegroup_status {
     my ($cdom,$cnum,$group) = @_;      my ($cdom,$cnum,$group,$action) = @_;
     my %curr_group = &get_coursegroups($cdom,$cnum,$group);      my ($from_namespace,$to_namespace);
       if ($action eq 'delete') {
           $from_namespace = 'coursegroups';
           $to_namespace = 'deleted_groups';
       } else {
           $from_namespace = 'deleted_groups';
           $to_namespace = 'coursegroups';
       }
       my %curr_group = &get_coursegroups($cdom,$cnum,$group,$from_namespace);
     if (my $tmp = &error(%curr_group)) {      if (my $tmp = &error(%curr_group)) {
         &Apache::lonnet::logthis('Error retrieving group: '.$tmp.' in '.$cnum.':'.$cdom);          &Apache::lonnet::logthis('Error retrieving group: '.$tmp.' in '.$cnum.':'.$cdom);
         return ('read error',$tmp);          return ('read error',$tmp);
     } else {      } else {
         my %savedsettings = %curr_group;           my %savedsettings = %curr_group; 
         my $result = &put('deleted_groups',\%savedsettings,$cdom,$cnum);          my $result = &put($to_namespace,\%savedsettings,$cdom,$cnum);
         my $deloutcome;          my $deloutcome;
         if ($result eq 'ok') {          if ($result eq 'ok') {
             $deloutcome = &del('coursegroups',[$group],$cdom,$cnum);              $deloutcome = &del($from_namespace,[$group],$cdom,$cnum);
         } else {          } else {
             return ('write error',$result);              return ('write error',$result);
         }          }
Line 4427  sub get_active_groups { Line 4466  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_courseid)/(\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 4487  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 4533  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 4572  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_courseid)\/.*/$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 4582  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_courseid)/.*}{$1/$2};
         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 4592  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_courseid)\/.*/$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 4672  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 4922  ENDINITMAP Line 4958  ENDINITMAP
     return '/'.$udom.'/'.$uname;      return '/'.$udom.'/'.$uname;
 }  }
   
   sub is_course {
       my ($cdom,$cnum) = @_;
       my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,
    undef,'.');
       if (exists($courses{$cdom.'_'.$cnum})) {
           return 1;
       }
       return 0;
   }
   
 # ---------------------------------------------------------- Assign Custom Role  # ---------------------------------------------------------- Assign Custom Role
   
 sub assigncustomrole {  sub assigncustomrole {
Line 5411  sub dirlist { Line 5457  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 5481  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_name)/?(.*)-);
  $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 6068  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 7046  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_name)/+(.*)|);
     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 7163  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_name)/+(.*)$-);
         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 7205  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_name)/userfiles/
     -/uploaded/$1/$2/-x;      -/uploaded/$1/$2/-x;
     }      }
     return $file;      return $file;
Line 7716  passed in @what from the requested user' Line 7762  passed in @what from the requested user'
   
 =item *  =item *
   
 allowed($priv,$uri) : check for a user privilege; returns codes for allowed  allowed($priv,$uri,$symb,$role) : check for a user privilege; returns codes for allowed actions
 actions  
  F: full access   F: full access
  U,I,K: authentication modes (cxx only)   U,I,K: authentication modes (cxx only)
  '': forbidden   '': forbidden
Removed from v.1.806  
changed lines
  Added in v.1.814

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