[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.744 and 1.758

version 1.744, 2006/06/05 20:09:19 version 1.758, 2006/06/26 18:56:03
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 4100  sub devalidate_getgroups_cache { Line 4110  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 4555  sub is_locked { Line 4568  sub is_locked {
       $env{'user.domain'},$env{'user.name'});        $env{'user.domain'},$env{'user.name'});
     my ($tmp)=keys(%locked);      my ($tmp)=keys(%locked);
     if ($tmp=~/^error:/) { undef(%locked); }      if ($tmp=~/^error:/) { undef(%locked); }
       
     if (ref($locked{$file_name}) eq 'ARRAY') {      if (ref($locked{$file_name}) eq 'ARRAY') {
         $is_locked = 'true';          $is_locked = 'false';
           foreach my $entry (@{$locked{$file_name}}) {
              if (ref($entry) eq 'ARRAY') { 
                  $is_locked = 'true';
                  last;
              }
          }
     } else {      } else {
         $is_locked = 'false';          $is_locked = 'false';
     }      }
Line 4646  sub files_not_in_path { Line 4665  sub files_not_in_path {
     return (@return_files);      return (@return_files);
 }  }
   
 #--------------------------------------------------------------Get Marked as Read Only  #----------------------------------------------Get portfolio file permissions
   
   
 sub get_marked_as_readonly {  sub get_portfile_permissions {
     my ($domain,$user,$what) = @_;      my ($domain,$user) = @_;
     my %current_permissions = &dump('file_permissions',$domain,$user);      my %current_permissions = &dump('file_permissions',$domain,$user);
     my ($tmp)=keys(%current_permissions);      my ($tmp)=keys(%current_permissions);
     if ($tmp=~/^error:/) { undef(%current_permissions); }      if ($tmp=~/^error:/) { undef(%current_permissions); }
       return \%current_permissions;
   }
   
   #---------------------------------------------Get portfolio file access controls
   
   sub get_access_controls {
       my ($current_permissions,$group,$file) = @_;
       my %access; 
       if (defined($file)) {
           if (ref($$current_permissions{$file."\0".'accesscontrol'}) eq 'HASH') {
               foreach my $control (keys(%{$$current_permissions{$file."\0".'accesscontrol'}})) {
                   $access{$file}{$control} = $$current_permissions{$file."\0".$control};
               }
           }
       } else {
           foreach my $key (keys(%{$current_permissions})) {
               if ($key =~ /\0accesscontrol$/) {
                   if (defined($group)) {
                       if ($key !~ m-^\Q$group\E/-) {
                           next;
                       }
                   }
                   my ($fullpath) = split(/\0/,$key);
                   if (ref($$current_permissions{$key}) eq 'HASH') {
                       foreach my $control (keys(%{$$current_permissions{$key}})) {
                           $access{$fullpath}{$control}=$$current_permissions{$fullpath."\0".$control};
                       }
                   }
               }
           }
       }
       return %access;
   }
   
   sub modify_access_controls {
       my ($file_name,$changes,$domain,$user)=@_;
       my ($outcome,$deloutcome);
       my %store_permissions;
       my %new_values;
       my %new_control;
       my %translation;
       my @deletions = ();
       my $now = time;
       if (exists($$changes{'activate'})) {
           if (ref($$changes{'activate'}) eq 'HASH') {
               my @newitems = sort(keys(%{$$changes{'activate'}}));
               my $numnew = scalar(@newitems);
               for (my $i=0; $i<$numnew; $i++) {
                   my $newkey = $newitems[$i];
                   my $newid = &Apache::loncommon::get_cgi_id();
                   $newkey =~ s/^(\d+)/$newid/;
                   $translation{$1} = $newid;
                   $new_values{$file_name."\0".$newkey} = 
                                             $$changes{'activate'}{$newitems[$i]};
                   $new_control{$newkey} = $now;
               }
           }
       }
       my %todelete;
       my %changed_items;
       foreach my $action ('delete','update') {
           if (exists($$changes{$action})) {
               if (ref($$changes{$action}) eq 'HASH') {
                   foreach my $key (keys(%{$$changes{$action}})) {
                       my ($itemnum) = ($key =~ /^([^:]+):/);
                       if ($action eq 'delete') { 
                           $todelete{$itemnum} = 1;
                       } else {
                           $changed_items{$itemnum} = $key;
                       }
                   }
               }
           }
       }
       # get lock on access controls for file.
       my $lockhash = {
                     $file_name."\0".'locked_access_records' => $env{'user.name'}.
                                                          ':'.$env{'user.domain'},
                      }; 
       my $tries = 0;
       my $gotlock = &newput('file_permissions',$lockhash,$domain,$user);
      
       while (($gotlock ne 'ok') && $tries <3) {
           $tries ++;
           sleep 1;
           $gotlock = &newput('file_permissions',$lockhash,$domain,$user);
       }
       if ($gotlock eq 'ok') {
           my %curr_permissions = &dump('file_permissions',$domain,$user,$file_name);
           my ($tmp)=keys(%curr_permissions);
           if ($tmp=~/^error:/) { undef(%curr_permissions); }
           if (exists($curr_permissions{$file_name."\0".'accesscontrol'})) {
               my $curr_controls = $curr_permissions{$file_name."\0".'accesscontrol'};
               if (ref($curr_controls) eq 'HASH') {
                   foreach my $control_item (keys(%{$curr_controls})) {
                       my ($itemnum) = ($control_item =~ /^([^:]+):/);
                       if (defined($todelete{$itemnum})) {
                           push(@deletions,$file_name."\0".$control_item);
                       } else {
                           if (defined($changed_items{$itemnum})) {
                               $new_control{$changed_items{$itemnum}} = $now;
                               push(@deletions,$file_name."\0".$control_item);
                               $new_values{$file_name."\0".$changed_items{$itemnum}} = $$changes{'update'}{$changed_items{$itemnum}};
                           } else {
                               $new_control{$control_item} = $$curr_controls{$control_item};
                           }
                       }
                   }
               }
           }
           $deloutcome = &del('file_permissions',\@deletions,$domain,$user);
           $new_values{$file_name."\0".'accesscontrol'} = \%new_control;
           $outcome = &put('file_permissions',\%new_values,$domain,$user);
           #  remove lock
           my @del_lock = ($file_name."\0".'locked_access_records');
           my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user);
       } else {
           $outcome = "error: could not obtain lockfile\n";  
       }
       return ($outcome,$deloutcome,\%new_values,\%translation);
   }
   
   #------------------------------------------------------Get Marked as Read Only
   
   sub get_marked_as_readonly {
       my ($domain,$user,$what,$group) = @_;
       my $current_permissions = &get_portfile_permissions($domain,$user);
     my @readonly_files;      my @readonly_files;
     my $cmp1=$what;      my $cmp1=$what;
     if (ref($what)) { $cmp1=join('',@{$what}) };      if (ref($what)) { $cmp1=join('',@{$what}) };
     while (my ($file_name,$value) = each(%current_permissions)) {      while (my ($file_name,$value) = each(%{$current_permissions})) {
           if (defined($group)) {
               if ($file_name !~ m-^\Q$group\E/-) {
                   next;
               }
           }
         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)) { $cmp2=join('',@{$stored_what}) };                  if (ref($stored_what eq 'ARRAY')) {
                       $cmp2=join('',@{$stored_what});
                   }
                 if ($cmp1 eq $cmp2) {                  if ($cmp1 eq $cmp2) {
                     push(@readonly_files, $file_name);                      push(@readonly_files, $file_name);
                       last;
                 } elsif (!defined($what)) {                  } elsif (!defined($what)) {
                     push(@readonly_files, $file_name);                      push(@readonly_files, $file_name);
                       last;
                 }                  }
             }              }
         }           }
     }      }
     return @readonly_files;      return @readonly_files;
 }  }
 #-----------------------------------------------------------Get Marked as Read Only Hash  #-----------------------------------------------------------Get Marked as Read Only Hash
   
 sub get_marked_as_readonly_hash {  sub get_marked_as_readonly_hash {
     my ($domain,$user,$what) = @_;      my ($current_permissions,$group,$what) = @_;
     my %current_permissions = &dump('file_permissions',$domain,$user);  
     my ($tmp)=keys(%current_permissions);  
     if ($tmp=~/^error:/) { undef(%current_permissions); }  
   
     my %readonly_files;      my %readonly_files;
     while (my ($file_name,$value) = each(%current_permissions)) {      while (my ($file_name,$value) = each(%{$current_permissions})) {
           if (defined($group)) {
               if ($file_name !~ m-^\Q$group\E/-) {
                   next;
               }
           }
         if (ref($value) eq "ARRAY"){          if (ref($value) eq "ARRAY"){
             foreach my $stored_what (@{$value}) {              foreach my $stored_what (@{$value}) {
                 if ($stored_what eq $what) {                  if (ref($stored_what) eq 'ARRAY') {
                     $readonly_files{$file_name} = 'locked';                      foreach my $lock_descriptor(@{$stored_what}) {
                 } elsif (!defined($what)) {                          if ($lock_descriptor eq 'graded') {
                     $readonly_files{$file_name} = 'locked';                              $readonly_files{$file_name} = 'graded';
                 }                          } elsif ($lock_descriptor eq 'handback') {
                               $readonly_files{$file_name} = 'handback';
                           } else {
                               if (!exists($readonly_files{$file_name})) {
                                   $readonly_files{$file_name} = 'locked';
                               }
                           }
                       }
                   } 
             }              }
         }           } 
     }      }
Line 4699  sub get_marked_as_readonly_hash { Line 4862  sub get_marked_as_readonly_hash {
 sub unmark_as_readonly {  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) = @_;      my ($domain,$user,$what,$file_name,$group) = @_;
     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);      my %current_permissions = &dump('file_permissions',$domain,$user,$group);
     my ($tmp)=keys(%current_permissions);      my ($tmp)=keys(%current_permissions);
     if ($tmp=~/^error:/) { undef(%current_permissions); }      if ($tmp=~/^error:/) { undef(%current_permissions); }
     my @readonly_files = &get_marked_as_readonly($domain,$user,$what);      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; }   if (defined($file_name) && ($file_name ne $file)) { next; }
  my $current_locks = $current_permissions{$file};   my $current_locks = $current_permissions{$file};
Line 4714  sub unmark_as_readonly { Line 4877  sub unmark_as_readonly {
         if (ref($current_locks) eq "ARRAY"){          if (ref($current_locks) eq "ARRAY"){
             foreach my $locker (@{$current_locks}) {              foreach my $locker (@{$current_locks}) {
                 my $compare=$locker;                  my $compare=$locker;
                 if (ref($locker)) { $compare=join('',@{$locker}) };                  if (ref($locker) eq 'ARRAY') {
                 if ($compare ne $symb_crs) {                      $compare=join('',@{$locker});
                     push(@new_locks, $locker);                      if ($compare ne $symb_crs) {
                           push(@new_locks, $locker);
                       }
                 }                  }
             }              }
             if (scalar(@new_locks) > 0) {              if (scalar(@new_locks) > 0) {
Line 7505  cput($namespace,$storehash,$udom,$uname) Line 7670  cput($namespace,$storehash,$udom,$uname)
   
 =item *  =item *
   
   newput($namespace,$storehash,$udom,$uname) :
   
   Attempts to store the items in the $storehash, but only if they don't
   currently exist, if this succeeds you can be certain that you have 
   successfully created a new key value pair in the $namespace db.
   
   
   Args:
    $namespace: name of database to store values to
    $storehash: hashref to store to the db
    $udom: (optional) domain of user containing the db
    $uname: (optional) name of user caontaining the db
   
   Returns:
    'ok' -> succeeded in storing all keys of $storehash
    'key_exists: <key>' -> failed to anything out of $storehash, as at
                           least <key> already existed in the db (other
                           requested keys may also already exist)
    'error: <msg>' -> unable to tie the DB or other erorr occured
    'con_lost' -> unable to contact request server
    'refused' -> action was not allowed by remote machine
   
   
   =item *
   
 eget($namespace,$storearr,$udom,$uname) : returns hash with keys from array  eget($namespace,$storearr,$udom,$uname) : returns hash with keys from array
 reference filled in from namesp (encrypts the return communication)  reference filled in from namesp (encrypts the return communication)
 ($udom and $uname are optional)  ($udom and $uname are optional)
Line 7739  removeuploadedurl(): convience function Line 7929  removeuploadedurl(): convience function
   Args:    Args:
    url:  a full /uploaded/... url to delete     url:  a full /uploaded/... url to delete
   
   =item * 
   
   get_portfile_permissions():
     Args:
       domain: domain of user or course contain the portfolio files
       user: name of user or num of course contain the portfolio files
     Returns:
       hashref of a dump of the proper file_permissions.db
      
   
   =item * 
   
   get_access_controls():
   
   Args:
     current_permissions: the hash ref returned from get_portfile_permissions()
     group: (optional) the group you want the files associated with
     file: (optional) the file you want access info on
   
   Returns:
       a hash (keys are file names) of hashes containing
           keys are: path to file/file_name\0uniqueID:scope_end_start (see below)
           values are XML containing access control settings (see below) 
   
   Internal notes:
   
    access controls are stored in file_permissions.db as key=value pairs.
       key -> path to file/file_name\0uniqueID:scope_end_start
           where scope -> public,guest,course,group,domains or users.
                 end -> UNIX time for end of access (0 -> no end date)
                 start -> UNIX time for start of access
   
       value -> XML description of access control
              <scope type=""> (type =1 of: public,guest,course,group,domains,users">
               <start></start>
               <end></end>
   
               <password></password>  for scope type = guest
   
               <domain></domain>     for scope type = course or group
               <number></number>
               <roles id="">
                <role></role>
                <access></access>
                <section></section>
                <group></group>
               </roles>
   
               <dom></dom>         for scope type = domains
   
               <users>             for scope type = users
                <user>
                 <uname></uname>
                 <udom></udom>
                </user>
               </users>
              </scope> 
                 
    Access data is also aggregated for each file in an additional key=value pair:
    key -> path to file/file_name\0accesscontrol 
    value -> reference to hash
             hash contains key = value pairs
             where key = uniqueID:scope_end_start
                   value = UNIX time record was last updated
   
             Used to improve speed of look-ups of access controls for each file.  
    
    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():
   
   Modifies access controls for a portfolio file
   Args
   1. file name
   2. reference to hash of required changes,
   3. domain
   4. username
     where domain,username are the domain of the portfolio owner 
     (either a user or a course) 
   
   Returns:
   1. result of additions or updates ('ok' or 'error', with error message). 
   2. result of deletions ('ok' or 'error', with error message).
   3. reference to hash of any new or updated access controls.
   4. reference to hash used to map incoming IDs to uniqueIDs assigned to control.
      key = integer (inbound ID)
      value = uniqueID  
   
 =back  =back
   
 =head2 HTTP Helper Routines  =head2 HTTP Helper Routines
Removed from v.1.744  
changed lines
  Added in v.1.758

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