[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.746 and 1.756

version 1.746, 2006/06/07 21:15:10 version 1.756, 2006/06/22 14:48:40
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 2922  sub del { Line 2933  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 4655  sub files_not_in_path { Line 4668  sub files_not_in_path {
 #----------------------------------------------Get portfolio file permissions  #----------------------------------------------Get portfolio file permissions
   
 sub get_portfile_permissions {  sub get_portfile_permissions {
     # returns a reference to a hash containing contents of file_permissions.db   
     my ($domain,$user) = @_;      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);
Line 4665  sub get_portfile_permissions { Line 4677  sub get_portfile_permissions {
   
 #---------------------------------------------Get portfolio file access controls  #---------------------------------------------Get portfolio file access controls
   
 sub get_access_controls  {  sub get_access_controls {
     # returns a hash containing access control information retrieved from  
     # file_permissions.db. The hash contains key=value pairs where key is  
     # the control type, end date and start date, in the form type_end_start  
     # and value is a string containing access control settings (in XML),  
     #  
     # Internally access_controls are stored in file_permissions.db in an  
     # array of arrays and a hash, where arrays are locks set when a portfolio     
     # file has been uploaded to an essayresponse problem in a course, and  
     # the hash contains other data. Two keys are currently defined in the hash:    
     # access and accesscount. The value for accesscount is a scalar - equal to   
     # the next number to use as the first part of an access control key  
     # when defining a new control. The value for access is an anonymous hash  
     # where keys are access controls and values are settings.  
     #      
     my ($current_permissions,$group,$file) = @_;      my ($current_permissions,$group,$file) = @_;
     my @access_checks = ();  
     my %access;       my %access; 
     if (defined($file)) {      if (defined($file)) {
         @access_checks = ($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 {      } else {
         @access_checks = keys(%{$current_permissions});          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};
                       }
                   }
               }
           }
     }      }
     foreach my $file_name (@access_checks) {      return %access;
         my $value = $$current_permissions{$file_name};  }
         if (defined($group)) {  
             if ($file_name !~ m-^\Q$group\E/-) {  sub parse_access_controls {
                 next;      my ($access_item) = @_;
       my %content;
       my $role_id;
       my $user;
       my $usercount;
       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'};
                   if (($type eq 'course') || ($type eq 'group')) {
                       $content{'roles'} = {};
                   }
               } elsif ($entry eq 'roles') {
                   $role_id = $token->[2]{id};
    $content{$entry}{$role_id} = {
                                    role => [],
                                                    access => [],
                                                    section => [],
                                                    group => [],
                                                };
               } elsif ($entry eq 'users') {
                   $content{'users'} = {};
                   $usercount = 0;
               } elsif ($entry eq 'user') {
                   $user = '';
               } else {
                   my $value=$parser->get_text('/'.$entry);
                   if ($entry eq 'uname') {
                       $user = $value;
                   } elsif ($entry eq 'udom') {
                       $user .= ':'.$value;
                       $content{'users'}{$user} = $usercount;
                   } elsif ($entry eq 'role' ||
                       $entry eq 'access' ||
                       $entry eq 'section' ||
                       $entry eq 'group') {
                       if ($role_id ne '') {
                           push(@{$content{'roles'}{$role_id}{$entry}},$value);
                       }
                   } elsif ($entry eq 'dom') {
                       push(@{$content{$entry}},$value);
                   } else {
                       $content{$entry}=$value;
                   }
               }
           } elsif ($token->[0] eq 'E') {
               if ($token->[1] eq 'user') {
                   $user = '';
                   $usercount ++;
               } elsif ($token->[1] eq 'roles') {
                   $role_id = '';
             }              }
         }          }
         if (ref($value) eq "ARRAY") {      }
             foreach my $stored_what (@{$value}) {      return %content;
                 if (ref($stored_what) eq 'HASH') {  }
                     $access{$file_name} = $$stored_what{'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;
                       }
                 }                  }
             }              }
         }          }
     }      }
     return %access;      # 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  #------------------------------------------------------Get Marked as Read Only
Line 4723  sub get_marked_as_readonly { Line 4872  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 'HASH')) {                  if (ref($stored_what eq 'ARRAY')) {
                     next;  
                 } elsif (ref($stored_what eq 'ARRAY')) {  
                     $cmp2=join('',@{$stored_what});                      $cmp2=join('',@{$stored_what});
                 }                  }
                 if ($cmp1 eq $cmp2) {                  if ($cmp1 eq $cmp2) {
Line 4754  sub get_marked_as_readonly_hash { Line 4901  sub get_marked_as_readonly_hash {
         if (ref($value) eq "ARRAY"){          if (ref($value) eq "ARRAY"){
             foreach my $stored_what (@{$value}) {              foreach my $stored_what (@{$value}) {
                 if (ref($stored_what) eq 'ARRAY') {                  if (ref($stored_what) eq 'ARRAY') {
                     if ($stored_what eq $what) {                      foreach my $lock_descriptor(@{$stored_what}) {
                         $readonly_files{$file_name} = 'locked';                          if ($lock_descriptor eq 'graded') {
                     } elsif (!defined($what)) {                              $readonly_files{$file_name} = 'graded';
                         $readonly_files{$file_name} = 'locked';                          } elsif ($lock_descriptor eq 'handback') {
                               $readonly_files{$file_name} = 'handback';
                           } else {
                               if (!exists($readonly_files{$file_name})) {
                                   $readonly_files{$file_name} = 'locked';
                               }
                           }
                     }                      }
                 }                  } 
             }              }
         }           } 
     }      }
Line 4785  sub unmark_as_readonly { Line 4938  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) eq 'ARRAY') {                  if (ref($locker) eq 'ARRAY') {
                     push(@new_locks,$locker);  
                 } else {     
                     $compare=join('',@{$locker});                      $compare=join('',@{$locker});
                     if ($compare ne $symb_crs) {                      if ($compare ne $symb_crs) {
                         push(@new_locks, $locker);                          push(@new_locks, $locker);
Line 7580  cput($namespace,$storehash,$udom,$uname) Line 7731  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 7814  removeuploadedurl(): convience function Line 7990  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.746  
changed lines
  Added in v.1.756

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