[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.750 and 1.766

version 1.750, 2006/06/19 21:01:01 version 1.766, 2006/07/21 19:42:25
Line 281  sub critical { Line 281  sub critical {
     return $answer;      return $answer;
 }  }
   
   # ------------------------------------------- check if return value is an error
   
   sub error {
       my ($result) = @_;
       if ($result =~ /^(con_lost|no_such_host|error: (\d+) (.*))/) {
    if ($2 == 2) { return undef; }
    return $1;
       }
       return undef;
   }
   
 # ------------------------------------------- Transfer profile into environment  # ------------------------------------------- Transfer profile into environment
   
 sub transfer_profile_to_env {  sub transfer_profile_to_env {
Line 1874  sub get_course_adv_roles { Line 1885  sub get_course_adv_roles {
     (!$nothide{$username.':'.$domain})) { next; }      (!$nothide{$username.':'.$domain})) { next; }
  if ($role eq 'cr') { next; }   if ($role eq 'cr') { next; }
         my $key=&plaintext($role);          my $key=&plaintext($role);
  if ($role =~ /^cr/) {  
     $key=(split('/',$role))[3];  
  }  
         if ($section) { $key.=' (Sec/Grp '.$section.')'; }          if ($section) { $key.=' (Sec/Grp '.$section.')'; }
         if ($returnhash{$key}) {          if ($returnhash{$key}) {
     $returnhash{$key}.=','.$username.':'.$domain;      $returnhash{$key}.=','.$username.':'.$domain;
Line 2922  sub del { Line 2930  sub del {
 # -------------------------------------------------------------- dump interface  # -------------------------------------------------------------- dump interface
   
 sub dump {  sub dump {
    my ($namespace,$udomain,$uname,$regexp,$range)=@_;      my ($namespace,$udomain,$uname,$regexp,$range)=@_;
    if (!$udomain) { $udomain=$env{'user.domain'}; }      if (!$udomain) { $udomain=$env{'user.domain'}; }
    if (!$uname) { $uname=$env{'user.name'}; }      if (!$uname) { $uname=$env{'user.name'}; }
    my $uhome=&homeserver($uname,$udomain);      my $uhome=&homeserver($uname,$udomain);
    if ($regexp) {      if ($regexp) {
        $regexp=&escape($regexp);   $regexp=&escape($regexp);
    } else {      } else {
        $regexp='.';   $regexp='.';
    }      }
    my $rep=reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);      my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
    my @pairs=split(/\&/,$rep);      my @pairs=split(/\&/,$rep);
    my %returnhash=();      my %returnhash=();
    foreach (@pairs) {      foreach my $item (@pairs) {
       my ($key,$value)=split(/=/,$_,2);   my ($key,$value)=split(/=/,$item,2);
       $returnhash{unescape($key)}=&thaw_unescape($value);   $key = &unescape($key);
    }   next if ($key =~ /^error: 2 /);
    return %returnhash;   $returnhash{$key}=&thaw_unescape($value);
       }
       return %returnhash;
 }  }
   
 # --------------------------------------------------------- dumpstore interface  # --------------------------------------------------------- dumpstore interface
Line 3207  sub tmpdel { Line 3217  sub tmpdel {
     return &reply("tmpdel:$token",$server);      return &reply("tmpdel:$token",$server);
 }  }
   
   # -------------------------------------------------- portfolio access checking
   
   sub portfolio_access {
       my ($requrl) = @_;
       my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl);
       my $result = &get_portfolio_access($udom,$unum,$file_name,$group);
       if ($result eq 'ok') {
          return 'F';
       } elsif ($result =~ /^[^:]+:guest_/) {
          return 'A';
       }
       return '';
   }
   
   sub get_portfolio_access {
       my ($udom,$unum,$file_name,$group) = @_;
    
       my $current_perms = &get_portfile_permissions($udom,$unum);
       my %access_controls = &get_access_controls($current_perms,$group,
          $file_name);
       my ($public,$guest,@domains,@users,@courses,@groups);
       my $now = time;
       my $access_hash = $access_controls{$file_name};
       if (ref($access_hash) eq 'HASH') {
           foreach my $key (keys(%{$access_hash})) {
               my ($num,$scope,$end,$start) = ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/);
               if ($start > $now) {
                   next;
               }
               if ($end && $end<$now) {
                   next;
               }
               if ($scope eq 'public') {
                   $public = $key;
                   last;
               } elsif ($scope eq 'guest') {
                   $guest = $key;
               } elsif ($scope eq 'domains') {
                   push(@domains,$key);
               } elsif ($scope eq 'users') {
                   push(@users,$key);
               } elsif ($scope eq 'course') {
                   push(@courses,$key);
               } elsif ($scope eq 'group') {
                   push(@groups,$key);
               }
           }
           if ($public) {
               return 'ok';
           }
           if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
               if ($guest) {
                   return $guest;
               }
           } else {
               if (@domains > 0) {
                   foreach my $domkey (@domains) {
                       if (ref($access_hash->{$domkey}{'dom'}) eq 'ARRAY') {
                           if (grep(/^\Q$env{'user.domain'}\E$/,@{$access_hash->{$domkey}{'dom'}})) {
                               return 'ok';
                           }
                       }
                   }
               }
               if (@users > 0) {
                   foreach my $userkey (@users) {
                       if (exists($access_hash->{$userkey}{'users'}{$env{'user.name'}.':'.$env{'user.domain'}})) {
                           return 'ok';
                       }
                   }
               }
               my %roleshash;
               my @courses_and_groups = @courses;
               push(@courses_and_groups,@groups); 
               if (@courses_and_groups > 0) {
                   my (%allgroups,%allroles); 
                   my ($start,$end,$role,$sec,$group);
                   foreach my $envkey (%env) {
                       if ($envkey =~ m-^user\.role\.(gr|cc|in|ta|ep|st)\./([^/]+)/([^/]+)/?([^/]*)$-) {
                           my $cid = $2.'_'.$3; 
                           if ($1 eq 'gr') {
                               $group = $4;
                               $allgroups{$cid}{$group} = $env{$envkey};
                           } else {
                               if ($4 eq '') {
                                   $sec = 'none';
                               } else {
                                   $sec = $4;
                               }
                               $allroles{$cid}{$1}{$sec} = $env{$envkey};
                           }
                       } elsif ($envkey =~ m-^user\.role\./cr/(\w+/\w+/\w*)./([^/]+)/([^/]+)/?([^/]*)$-) {
                           my $cid = $2.'_'.$3;
                           if ($4 eq '') {
                               $sec = 'none';
                           } else {
                               $sec = $4;
                           }
                           $allroles{$cid}{$1}{$sec} = $env{$envkey};
                       }
                   }
                   if (keys(%allroles) == 0) {
                       return;
                   }
                   foreach my $key (@courses_and_groups) {
                       my %content = %{$$access_hash{$key}};
                       my $cnum = $content{'number'};
                       my $cdom = $content{'domain'};
                       my $cid = $cdom.'_'.$cnum;
                       if (!exists($allroles{$cid})) {
                           next;
                       }    
                       foreach my $role_id (keys(%{$content{'roles'}})) {
                           my @sections = @{$content{'roles'}{$role_id}{'section'}};
                           my @groups = @{$content{'roles'}{$role_id}{'group'}};
                           my @status = @{$content{'roles'}{$role_id}{'access'}};
                           my @roles = @{$content{'roles'}{$role_id}{'role'}};
                           foreach my $role (keys(%{$allroles{$cid}})) {
                               if ((grep/^all$/,@roles) || (grep/^\Q$role\E$/,@roles)) {
                                   foreach my $sec (keys(%{$allroles{$cid}{$role}})) {
                                       if (&course_group_datechecker($allroles{$cid}{$role}{$sec},$now,\@status) eq 'ok') {
                                           if (grep/^all$/,@sections) {
                                               return 'ok';
                                           } else {
                                               if (grep/^$sec$/,@sections) {
                                                   return 'ok';
                                               }
                                           }
                                       }
                                   }
                                   if (keys(%{$allgroups{$cid}}) == 0) {
                                       if (grep/^none$/,@groups) {
                                           return 'ok';
                                       }
                                   } else {
                                       if (grep/^all$/,@groups) {
                                           return 'ok';
                                       } 
                                       foreach my $group (keys(%{$allgroups{$cid}})) {
                                           if (grep/^$group$/,@groups) {
                                               return 'ok';
                                           }
                                       }
                                   } 
                               }
                           }
                       }
                   }
               }
               if ($guest) {
                   return $guest;
               }
           }
       }
       return;
   }
   
   sub course_group_datechecker {
       my ($dates,$now,$status) = @_;
       my ($start,$end) = split(/\./,$dates);
       if (!$start && !$end) {
           return 'ok';
       }
       if (grep/^active$/,@{$status}) {
           if (((!$start) || ($start && $start <= $now)) && ((!$end) || ($end && $end >= $now))) {
               return 'ok';
           }
       }
       if (grep/^previous$/,@{$status}) {
           if ($end > $now ) {
               return 'ok';
           }
       }
       if (grep/^future$/,@{$status}) {
           if ($start > $now) {
               return 'ok';
           }
       }
       return; 
   }
   
   sub parse_portfolio_url {
       my ($url) = @_;
   
       my ($type,$udom,$unum,$group,$file_name);
       
       if ($url =~  m-^/*uploaded/([^/]+)/([^/]+)/portfolio(/.+)$-) {
    $type = 1;
           $udom = $1;
           $unum = $2;
           $file_name = $3;
       } elsif ($url =~ m-^/*uploaded/([^/]+)/([^/]+)/groups/([^/]+)/portfolio/(.+)$-) {
    $type = 2;
           $udom = $1;
           $unum = $2;
           $group = $3;
           $file_name = $3.'/'.$4;
       }
       if (wantarray) {
    return ($type,$udom,$unum,$file_name,$group);
       }
       return $type;
   }
   
   sub is_portfolio_url {
       my ($url) = @_;
       return scalar(&parse_portfolio_url($url));
   }
   
 # ---------------------------------------------- Custom access rule evaluation  # ---------------------------------------------- Custom access rule evaluation
   
 sub customaccess {  sub customaccess {
Line 3264  sub allowed { Line 3483  sub allowed {
         return 'F';          return 'F';
     }      }
   
 # bre access to group if user has rgf priv for this group and course.  # bre access to group portfolio for rgf priv in group, or mdg or vcg in course.
     if (($space=~/^(uploaded|editupload)$/) && ($dir[0] eq 'groups')       if (($space=~/^(uploaded|editupload)$/) && ($dir[0] eq 'groups') 
          && ($dir[2] eq 'portfolio') && ($priv eq 'bre')) {           && ($dir[2] eq 'portfolio') && ($priv eq 'bre')) {
         if (exists($env{'request.course.id'})) {          if (exists($env{'request.course.id'})) {
Line 3276  sub allowed { Line 3495  sub allowed {
                 if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid                  if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid
                     .'/'.$dir[1]} =~/rgf\&([^\:]*)/) {                      .'/'.$dir[1]} =~/rgf\&([^\:]*)/) {
                     return $1;                       return $1; 
                   } else {
                       if ($env{'request.course.sec'}) {
                           $courseprivid.='/'.$env{'request.course.sec'};
                       }
                       if ($env{'user.priv.'.$env{'request.role'}.'./'.
                           $courseprivid} =~/(mdg|vcg)\&([^\:]*)/) {
                           return $2;
                       }
                 }                  }
             }              }
         }          }
Line 3344  sub allowed { Line 3571  sub allowed {
        $thisallowed.=$1;         $thisallowed.=$1;
     }      }
   
 # 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  # 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/|)) {
Line 3378  sub allowed { Line 3597  sub allowed {
         }          }
     }      }
   
       if ($priv eq 'bre'
    && $thisallowed ne 'F' 
    && $thisallowed ne '2'
    && &is_portfolio_url($uri)) {
    $thisallowed = &portfolio_access($uri);
       }
       
 # Full access at system, domain or course-wide level? Exit.  # Full access at system, domain or course-wide level? Exit.
   
     if ($thisallowed=~/F/) {      if ($thisallowed=~/F/) {
Line 3528  sub allowed { Line 3754  sub allowed {
 #  #
   
     unless ($env{'request.course.id'}) {      unless ($env{'request.course.id'}) {
        return '1';   if ($thisallowed eq 'A') {
       return 'A';
    } else {
       return '1';
    }
     }      }
   
 #  #
Line 3591  sub allowed { Line 3821  sub allowed {
       }        }
    }     }
   
       if ($thisallowed eq 'A') {
    return 'A';
       }
    return 'F';     return 'F';
 }  }
   
Line 4100  sub devalidate_getgroups_cache { Line 4333  sub devalidate_getgroups_cache {
   
 sub plaintext {  sub plaintext {
     my ($short,$type,$cid) = @_;      my ($short,$type,$cid) = @_;
       if ($short =~ /^cr/) {
    return (split('/',$short))[-1];
       }
     if (!defined($cid)) {      if (!defined($cid)) {
         $cid = $env{'request.course.id'};          $cid = $env{'request.course.id'};
     }      }
Line 4569  sub is_locked { Line 4805  sub is_locked {
     }      }
 }  }
   
   sub declutter_portfile {
       my ($file) = @_;
       &logthis("got $file");
       $file =~ s-^(/portfolio/|portfolio/)-/-;
       &logthis("ret $file");
       return $file;
   }
   
 # ------------------------------------------------------------- Mark as Read Only  # ------------------------------------------------------------- Mark as Read Only
   
 sub mark_as_readonly {  sub mark_as_readonly {
Line 4577  sub mark_as_readonly { Line 4821  sub mark_as_readonly {
     my ($tmp)=keys(%current_permissions);      my ($tmp)=keys(%current_permissions);
     if ($tmp=~/^error:/) { undef(%current_permissions); }      if ($tmp=~/^error:/) { undef(%current_permissions); }
     foreach my $file (@{$files}) {      foreach my $file (@{$files}) {
    $file = &declutter_portfile($file);
         push(@{$current_permissions{$file}},$what);          push(@{$current_permissions{$file}},$what);
     }      }
     &put('file_permissions',\%current_permissions,$domain,$user);      &put('file_permissions',\%current_permissions,$domain,$user);
Line 4693  sub get_access_controls { Line 4938  sub get_access_controls {
     return %access;      return %access;
 }  }
   
 sub parse_access_controls {  
     my ($access_item) = @_;  
     my %content;  
     my $token;  
     my $parser=HTML::TokeParser->new(\$access_item);  
     while ($token=$parser->get_token) {  
         if ($token->[0] eq 'S')  {  
             my $entry=$token->[1];  
             if ($entry eq 'scope') {  
                 my $type = $token->[2]{'type'};  
             } else {  
                 my $value=$parser->get_text('/'.$entry);  
                 $content{$entry}=$value;  
             }  
         }  
     }  
     return %content;  
 }  
   
 sub modify_access_controls {  sub modify_access_controls {
     my ($file_name,$changes,$domain,$user)=@_;      my ($file_name,$changes,$domain,$user)=@_;
     my ($outcome,$deloutcome);      my ($outcome,$deloutcome);
Line 4817  sub get_marked_as_readonly { Line 5043  sub get_marked_as_readonly {
         if (ref($value) eq "ARRAY"){          if (ref($value) eq "ARRAY"){
             foreach my $stored_what (@{$value}) {              foreach my $stored_what (@{$value}) {
                 my $cmp2=$stored_what;                  my $cmp2=$stored_what;
                 if (ref($stored_what eq 'ARRAY')) {                  if (ref($stored_what) eq 'ARRAY') {
                     $cmp2=join('',@{$stored_what});                      $cmp2=join('',@{$stored_what});
                 }                  }
                 if ($cmp1 eq $cmp2) {                  if ($cmp1 eq $cmp2) {
Line 4869  sub unmark_as_readonly { Line 5095  sub unmark_as_readonly {
     # unmarks $file_name (if $file_name is defined), or all files locked by $what       # unmarks $file_name (if $file_name is defined), or all files locked by $what 
     # for portfolio submissions, $what contains [$symb,$crsid]       # for portfolio submissions, $what contains [$symb,$crsid] 
     my ($domain,$user,$what,$file_name,$group) = @_;      my ($domain,$user,$what,$file_name,$group) = @_;
       $file_name = &declutter_portfile($file_name);
     my $symb_crs = $what;      my $symb_crs = $what;
     if (ref($what)) { $symb_crs=join('',@$what); }      if (ref($what)) { $symb_crs=join('',@$what); }
     my %current_permissions = &dump('file_permissions',$domain,$user,$group);      my %current_permissions = &dump('file_permissions',$domain,$user,$group);
Line 4876  sub unmark_as_readonly { Line 5103  sub unmark_as_readonly {
     if ($tmp=~/^error:/) { undef(%current_permissions); }      if ($tmp=~/^error:/) { undef(%current_permissions); }
     my @readonly_files = &get_marked_as_readonly($domain,$user,$what,$group);      my @readonly_files = &get_marked_as_readonly($domain,$user,$what,$group);
     foreach my $file (@readonly_files) {      foreach my $file (@readonly_files) {
  if (defined($file_name) && ($file_name ne $file)) { next; }   my $clean_file = &declutter_portfile($file);
    if (defined($file_name) && ($file_name ne $clean_file)) { next; }
  my $current_locks = $current_permissions{$file};   my $current_locks = $current_permissions{$file};
         my @new_locks;          my @new_locks;
         my @del_keys;          my @del_keys;
Line 4923  sub dirlist { Line 5151  sub dirlist {
     if(defined($alternateDirectoryRoot)) {      if(defined($alternateDirectoryRoot)) {
         $dirRoot = $alternateDirectoryRoot;          $dirRoot = $alternateDirectoryRoot;
         $dirRoot =~ s/\/$//;          $dirRoot =~ s/\/$//;
     }Clay Greene      }
   
     if($udom) {      if($udom) {
         if($uname) {          if($uname) {
Line 5150  sub devalidatecourseresdata { Line 5378  sub devalidatecourseresdata {
     &devalidate_cache_new('courseres',$hashid);      &devalidate_cache_new('courseres',$hashid);
 }  }
   
   
 # --------------------------------------------------- Course Resourcedata Query  # --------------------------------------------------- Course Resourcedata Query
   
 sub get_courseresdata {  sub get_courseresdata {
Line 5871  sub metadata_generate_part0 { Line 6100  sub metadata_generate_part0 {
     }      }
 }  }
   
   # ------------------------------------------------------ Devalidate title cache
   
   sub devalidate_title_cache {
       my ($url)=@_;
       if (!$env{'request.course.id'}) { return; }
       my $symb=&symbread($url);
       if (!$symb) { return; }
       my $key=$env{'request.course.id'}."\0".$symb;
       &devalidate_cache_new('title',$key);
   }
   
 # ------------------------------------------------- Get the title of a resource  # ------------------------------------------------- Get the title of a resource
   
 sub gettitle {  sub gettitle {
Line 7277  actions Line 7517  actions
  '': forbidden   '': forbidden
  1: user needs to choose course   1: user needs to choose course
  2: browse allowed   2: browse allowed
    A: passphrase authentication needed
   
 =item *  =item *
   
Line 8004  Internal notes: Line 8245  Internal notes:
     
  Locks on files (resulting from submission of portfolio file to a homework problem stored in array of arrays.   Locks on files (resulting from submission of portfolio file to a homework problem stored in array of arrays.
   
 parse_access_controls():  
   
 Parses XML of an access control record  
 Args  
 1. Text string (XML) of access comtrol record  
   
 Returns:  
 1. Hash of access control settings.   
   
 modify_access_controls():  modify_access_controls():
   
 Modifies access controls for a portfolio file  Modifies access controls for a portfolio file
Removed from v.1.750  
changed lines
  Added in v.1.766

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