Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.942 and 1.957

version 1.942, 2008/02/21 10:04:35 version 1.957, 2008/04/30 22:42:59
Line 88  delayed. Line 88  delayed.
 {  {
     my $logid;      my $logid;
     sub instructor_log {      sub instructor_log {
  my ($hash_name,$storehash,$delflag,$uname,$udom)=@_;   my ($hash_name,$storehash,$delflag,$uname,$udom,$cnum,$cdom)=@_;
           if (($cnum eq '') || ($cdom eq '')) {
               $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
               $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
           }
  $logid++;   $logid++;
  my $id=time().'00000'.$$.'00000'.$logid;          my $now = time();
    my $id=$now.'00000'.$$.'00000'.$logid;
  return &Apache::lonnet::put('nohist_'.$hash_name,   return &Apache::lonnet::put('nohist_'.$hash_name,
     { $id => {      { $id => {
  'exe_uname' => $env{'user.name'},   'exe_uname' => $env{'user.name'},
  'exe_udom'  => $env{'user.domain'},   'exe_udom'  => $env{'user.domain'},
  'exe_time'  => time(),   'exe_time'  => $now,
  'exe_ip'    => $ENV{'REMOTE_ADDR'},   'exe_ip'    => $ENV{'REMOTE_ADDR'},
  'delflag'   => $delflag,   'delflag'   => $delflag,
  'logentry'  => $storehash,   'logentry'  => $storehash,
  'uname'     => $uname,   'uname'     => $uname,
  'udom'      => $udom,   'udom'      => $udom,
     }      }
   },    },$cdom,$cnum);
     $env{'course.'.$env{'request.course.id'}.'.domain'},  
     $env{'course.'.$env{'request.course.id'}.'.num'}  
     );  
     }      }
 }  }
   
Line 448  sub timed_flock { Line 450  sub timed_flock {
 # ---------------------------------------------------------- Append Environment  # ---------------------------------------------------------- Append Environment
   
 sub appenv {  sub appenv {
     my %newenv=@_;      my ($newenv,$roles) = @_;
     foreach my $key (keys(%newenv)) {      if (ref($newenv) eq 'HASH') {
  if (($newenv{$key}=~/^user\.role/) || ($newenv{$key}=~/^user\.priv/)) {          foreach my $key (keys(%{$newenv})) {
             &logthis("<font color=\"blue\">WARNING: ".              my $refused = 0;
                 "Attempt to modify environment ".$key." to ".$newenv{$key}      if (($key =~ /^user\.role/) || ($key =~ /^user\.priv/)) {
                 .'</font>');                  $refused = 1;
     delete($newenv{$key});                  if (ref($roles) eq 'ARRAY') {
         } else {                      my ($type,$role) = ($key =~ /^user\.(role|priv)\.([^.]+)\./);
             $env{$key}=$newenv{$key};                      if (grep(/^\Q$role\E$/,@{$roles})) {
                           $refused = 0;
                       }
                   }
               }
               if ($refused) {
                   &logthis("<font color=\"blue\">WARNING: ".
                            "Attempt to modify environment ".$key." to ".$newenv->{$key}
                            .'</font>');
           delete($newenv->{$key});
               } else {
                   $env{$key}=$newenv->{$key};
               }
           }
           my $opened = open(my $env_file,'+<',$env{'user.environment'});
           if ($opened
       && &timed_flock($env_file,LOCK_EX)
       &&
       tie(my %disk_env,'GDBM_File',$env{'user.environment'},
           (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
       while (my ($key,$value) = each(%{$newenv})) {
           $disk_env{$key} = $value;
       }
       untie(%disk_env);
         }          }
     }  
     my $opened = open(my $env_file,'+<',$env{'user.environment'});  
     if ($opened  
  && &timed_flock($env_file,LOCK_EX)  
  &&  
  tie(my %disk_env,'GDBM_File',$env{'user.environment'},  
     (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {  
  while (my ($key,$value) = each(%newenv)) {  
     $disk_env{$key} = $value;  
  }  
  untie(%disk_env);  
     }      }
     return 'ok';      return 'ok';
 }  }
Line 693  sub queryauthenticate { Line 707  sub queryauthenticate {
 # --------- Try to authenticate user from domain's lib servers (first this one)  # --------- Try to authenticate user from domain's lib servers (first this one)
   
 sub authenticate {  sub authenticate {
     my ($uname,$upass,$udom)=@_;      my ($uname,$upass,$udom,$checkdefauth)=@_;
     $upass=&escape($upass);      $upass=&escape($upass);
     $uname= &LONCAPA::clean_username($uname);      $uname= &LONCAPA::clean_username($uname);
     my $uhome=&homeserver($uname,$udom,1);      my $uhome=&homeserver($uname,$udom,1);
       my $newhome;
     if ((!$uhome) || ($uhome eq 'no_host')) {      if ((!$uhome) || ($uhome eq 'no_host')) {
 # Maybe the machine was offline and only re-appeared again recently?  # Maybe the machine was offline and only re-appeared again recently?
         &reconlonc();          &reconlonc();
 # One more  # One more
  my $uhome=&homeserver($uname,$udom,1);   $uhome=&homeserver($uname,$udom,1);
           if (($uhome eq 'no_host') && $checkdefauth) {
               if (defined(&domain($udom,'primary'))) {
                   $newhome=&domain($udom,'primary');
               }
               if ($newhome ne '') {
                   $uhome = $newhome;
               }
           }
  if ((!$uhome) || ($uhome eq 'no_host')) {   if ((!$uhome) || ($uhome eq 'no_host')) {
     &logthis("User $uname at $udom is unknown in authenticate");      &logthis("User $uname at $udom is unknown in authenticate");
  }      return 'no_host';
  return 'no_host';          }
     }      }
     my $answer=reply("encrypt:auth:$udom:$uname:$upass",$uhome);      my $answer=reply("encrypt:auth:$udom:$uname:$upass:$checkdefauth",$uhome);
     if ($answer eq 'authorized') {      if ($answer eq 'authorized') {
  &logthis("User $uname at $udom authorized by $uhome");           if ($newhome) {
  return $uhome;               &logthis("User $uname at $udom authorized by $uhome, but needs account");
               return 'no_account_on_host'; 
           } else {
               &logthis("User $uname at $udom authorized by $uhome");
               return $uhome;
           }
     }      }
     if ($answer eq 'non_authorized') {      if ($answer eq 'non_authorized') {
  &logthis("User $uname at $udom rejected by $uhome");   &logthis("User $uname at $udom rejected by $uhome");
Line 1064  sub inst_rulecheck { Line 1092  sub inst_rulecheck {
                     $response=&unescape(&reply('instidrulecheck:'.&escape($udom).                      $response=&unescape(&reply('instidrulecheck:'.&escape($udom).
                                               ':'.&escape($id).':'.$rulestr,                                                ':'.&escape($id).':'.$rulestr,
                                               $homeserver));                                                $homeserver));
                   } elsif ($item eq 'selfcreate') {
                       $response=&unescape(&reply('instselfcreatecheck:'.
                                                  &escape($udom).':'.&escape($uname).
                                                 ':'.$rulestr,$homeserver));
                 }                  }
                 if ($response ne 'refused') {                  if ($response ne 'refused') {
                     my @pairs=split(/\&/,$response);                      my @pairs=split(/\&/,$response);
Line 1090  sub inst_userrules { Line 1122  sub inst_userrules {
             if ($check eq 'id') {              if ($check eq 'id') {
                 $response=&reply('instidrules:'.&escape($udom),                  $response=&reply('instidrules:'.&escape($udom),
                                  $homeserver);                                   $homeserver);
               } elsif ($check eq 'email') {
                   $response=&reply('instemailrules:'.&escape($udom),
                                    $homeserver);
             } else {              } else {
                 $response=&reply('instuserrules:'.&escape($udom),                  $response=&reply('instuserrules:'.&escape($udom),
                                  $homeserver);                                   $homeserver);
Line 1115  sub inst_userrules { Line 1150  sub inst_userrules {
     return (\%ruleshash,\@ruleorder);      return (\%ruleshash,\@ruleorder);
 }  }
   
   # ------------------------- Get Authentication and Language Defaults for Domain
   
   sub get_domain_defaults {
       my ($domain) = @_;
       my $cachetime = 60*60*24;
       my ($defauthtype,$defautharg,$deflang);
       my ($result,$cached)=&is_cached_new('domdefaults',$domain);
       if (defined($cached)) {
           if (ref($result) eq 'HASH') {
               return %{$result};
           }
       }
       my %domdefaults;
       my %domconfig =
            &Apache::lonnet::get_dom('configuration',['defaults'],$domain);
       if (ref($domconfig{'defaults'}) eq 'HASH') {
           $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; 
           $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};
           $domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'};
       } else {
           $domdefaults{'lang_def'} = &domain($domain,'lang_def');
           $domdefaults{'auth_def'} = &domain($domain,'auth_def');
           $domdefaults{'auth_arg_def'} = &domain($domain,'auth_arg_def');
       }
       &Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults,
                                     $cachetime);
       return %domdefaults;
   }
   
 # --------------------------------------------------- Assign a key to a student  # --------------------------------------------------- Assign a key to a student
   
 sub assign_access_key {  sub assign_access_key {
Line 1147  sub assign_access_key { Line 1211  sub assign_access_key {
 # key now belongs to user  # key now belongs to user
     my $envkey='key.'.$cdom.'_'.$cnum;      my $envkey='key.'.$cdom.'_'.$cnum;
             if (&put('environment',{$envkey => $ckey}) eq 'ok') {              if (&put('environment',{$envkey => $ckey}) eq 'ok') {
                 &appenv('environment.'.$envkey => $ckey);                  &appenv({'environment.'.$envkey => $ckey});
                 return 'ok';                  return 'ok';
             } else {              } else {
                 return                   return 
Line 1631  sub ssi_body { Line 1695  sub ssi_body {
     if (! exists($form{'LONCAPA_INTERNAL_no_discussion'})) {      if (! exists($form{'LONCAPA_INTERNAL_no_discussion'})) {
         $form{'LONCAPA_INTERNAL_no_discussion'}='true';          $form{'LONCAPA_INTERNAL_no_discussion'}='true';
     }      }
     my $output=($filelink=~/^http\:/?&externalssi($filelink):      my $output='';
                                      &ssi($filelink,%form));      my $response;
       if ($filelink=~/^http\:/) {
          ($output,$response)=&externalssi($filelink);
       } else {
          ($output,$response)=&ssi($filelink,%form);
       }
     $output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s*(-->)?\s||gs;      $output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s*(-->)?\s||gs;
     $output=~s/^.*?\<body[^\>]*\>//si;      $output=~s/^.*?\<body[^\>]*\>//si;
     $output=~s/\<\/body\s*\>.*?$//si;      $output=~s/\<\/body\s*\>.*?$//si;
     return $output;      if (wantarray) {
           return ($output, $response);
       } else {
           return $output;
       }
 }  }
   
 # --------------------------------------------------------- Server Side Include  # --------------------------------------------------------- Server Side Include
Line 1656  sub absolute_url { Line 1729  sub absolute_url {
 #  fn     Possibly encrypted resource name/id.  #  fn     Possibly encrypted resource name/id.
 #  form   Hash that describes how the rendering should be done  #  form   Hash that describes how the rendering should be done
 #         and other things.  #         and other things.
 #  r      Optional reference that will be given the response.  
 #         This is mostly provided so that the caller can implement  
 #         error detection, recovery and retry policies.  
 #       
 # Returns:  # Returns:
 #    The content of the response.  #   Scalar context: The content of the response.
   #   Array context:  2 element list of the content and the full response object.
   #     
 sub ssi {  sub ssi {
   
     my ($fn,%form, $r)=@_;      my ($fn,%form)=@_;
   
     my $ua=new LWP::UserAgent;      my $ua=new LWP::UserAgent;
       
     my $request;      my $request;
   
     $form{'no_update_last_known'}=1;      $form{'no_update_last_known'}=1;
Line 1682  sub ssi { Line 1751  sub ssi {
     $request->header(Cookie => $ENV{'HTTP_COOKIE'});      $request->header(Cookie => $ENV{'HTTP_COOKIE'});
     my $response=$ua->request($request);      my $response=$ua->request($request);
   
     if ($r) {      if (wantarray) {
  $$r = $response;   return ($response->content, $response);
       } else {
    return $response->content;
     }      }
   
     return $response->content;  
 }  }
   
 sub externalssi {  sub externalssi {
Line 1694  sub externalssi { Line 1763  sub externalssi {
     my $ua=new LWP::UserAgent;      my $ua=new LWP::UserAgent;
     my $request=new HTTP::Request('GET',$url);      my $request=new HTTP::Request('GET',$url);
     my $response=$ua->request($request);      my $response=$ua->request($request);
     return $response->content;      if (wantarray) {
           return ($response->content, $response);
       } else {
           return $response->content;
       }
 }  }
   
 # -------------------------------- Allow a /uploaded/ URI to be vouched for  # -------------------------------- Allow a /uploaded/ URI to be vouched for
Line 1707  sub allowuploaded { Line 1780  sub allowuploaded {
     my %httpref=();      my %httpref=();
     my $httpurl=&hreflocation('',$url);      my $httpurl=&hreflocation('',$url);
     $httpref{'httpref.'.$httpurl}=$srcurl;      $httpref{'httpref.'.$httpurl}=$srcurl;
     &Apache::lonnet::appenv(%httpref);      &Apache::lonnet::appenv(\%httpref);
 }  }
   
 # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course  # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course
Line 2409  sub userrolelog { Line 2482  sub userrolelog {
     }      }
 }  }
   
   sub courserolelog {
       my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$selfenroll,$context)=@_;
       if (($trole eq 'cc') || ($trole eq 'in') ||
           ($trole eq 'ep') || ($trole eq 'ad') ||
           ($trole eq 'ta') || ($trole eq 'st') ||
           ($trole=~/^cr/) || ($trole eq 'gr')) {
           if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) {
               my $cdom = $1;
               my $cnum = $2;
               my $sec = $3;
               my $namespace = 'rolelog';
               my %storehash = (
                                  role    => $trole,
                                  start   => $tstart,
                                  end     => $tend,
                                  selfenroll => $selfenroll,
                                  context    => $context,
                               );
               if ($trole eq 'gr') {
                   $namespace = 'groupslog';
                   $storehash{'group'} = $sec;
               } else {
                   $storehash{'section'} = $sec;
               }
               &instructor_log($namespace,\%storehash,$delflag,$username,$domain,$cnum,$cdom);
           }
       }
       return;
   }
   
 sub get_course_adv_roles {  sub get_course_adv_roles {
     my $cid=shift;      my ($cid,$codes) = @_;
     $cid=$env{'request.course.id'} unless (defined($cid));      $cid=$env{'request.course.id'} unless (defined($cid));
     my %coursehash=&coursedescription($cid);      my %coursehash=&coursedescription($cid);
     my %nothide=();      my %nothide=();
Line 2435  sub get_course_adv_roles { Line 2538  sub get_course_adv_roles {
  if ((&privileged($username,$domain)) &&    if ((&privileged($username,$domain)) && 
     (!$nothide{$username.':'.$domain})) { next; }      (!$nothide{$username.':'.$domain})) { next; }
  if ($role eq 'cr') { next; }   if ($role eq 'cr') { next; }
         my $key=&plaintext($role);          if ($codes) {
         if ($section) { $key.=' (Sec/Grp '.$section.')'; }              if ($section) { $role .= ':'.$section; }
         if ($returnhash{$key}) {              if ($returnhash{$role}) {
     $returnhash{$key}.=','.$username.':'.$domain;                  $returnhash{$role}.=','.$username.':'.$domain;
               } else {
                   $returnhash{$role}=$username.':'.$domain;
               }
         } else {          } else {
             $returnhash{$key}=$username.':'.$domain;              my $key=&plaintext($role);
               if ($section) { $key.=' (Section '.$section.')'; }
               if ($returnhash{$key}) {
           $returnhash{$key}.=','.$username.':'.$domain;
               } else {
                   $returnhash{$key}=$username.':'.$domain;
               }
         }          }
      }      }
     return %returnhash;      return %returnhash;
 }  }
   
Line 2604  sub courseidput { Line 2716  sub courseidput {
   
 sub courseiddump {  sub courseiddump {
     my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,      my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,
         $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_;          $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,
           $selfenrollonly)=@_;
     my $as_hash = 1;      my $as_hash = 1;
     my %returnhash;      my %returnhash;
     if (!$domfilter) { $domfilter=''; }      if (!$domfilter) { $domfilter=''; }
Line 2621  sub courseiddump { Line 2734  sub courseiddump {
                          $sincefilter.':'.&escape($descfilter).':'.                           $sincefilter.':'.&escape($descfilter).':'.
                          &escape($instcodefilter).':'.&escape($ownerfilter).                           &escape($instcodefilter).':'.&escape($ownerfilter).
                          ':'.&escape($coursefilter).':'.&escape($typefilter).                           ':'.&escape($coursefilter).':'.&escape($typefilter).
                          ':'.&escape($regexp_ok).':'.$as_hash,$tryserver);                           ':'.&escape($regexp_ok).':'.$as_hash.':'.
                            &escape($selfenrollonly),$tryserver);
                 my @pairs=split(/\&/,$rep);                  my @pairs=split(/\&/,$rep);
                 foreach my $item (@pairs) {                  foreach my $item (@pairs) {
                     my ($key,$value)=split(/\=/,$item,2);                      my ($key,$value)=split(/\=/,$item,2);
Line 3358  sub coursedescription { Line 3472  sub coursedescription {
        }         }
     }      }
     if (!$args->{'one_time'}) {      if (!$args->{'one_time'}) {
  &appenv(%envhash);   &appenv(\%envhash);
     }      }
     return %returnhash;      return %returnhash;
 }  }
Line 3907  sub tmpget { Line 4021  sub tmpget {
     my %returnhash;      my %returnhash;
     foreach my $item (split(/\&/,$rep)) {      foreach my $item (split(/\&/,$rep)) {
  my ($key,$value)=split(/=/,$item);   my ($key,$value)=split(/=/,$item);
           next if ($key =~ /^error: 2 /);
  $returnhash{&unescape($key)}=&thaw_unescape($value);   $returnhash{&unescape($key)}=&thaw_unescape($value);
     }      }
     return %returnhash;      return %returnhash;
Line 5153  sub toggle_coursegroup_status { Line 5268  sub toggle_coursegroup_status {
 }  }
   
 sub modify_group_roles {  sub modify_group_roles {
     my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs) = @_;      my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs,$selfenroll,$context) = @_;
     my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;      my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;
     my $role = 'gr/'.&escape($userprivs);      my $role = 'gr/'.&escape($userprivs);
     my ($uname,$udom) = split(/:/,$user);      my ($uname,$udom) = split(/:/,$user);
     my $result = &assignrole($udom,$uname,$url,$role,$end,$start);      my $result = &assignrole($udom,$uname,$url,$role,$end,$start,'',$selfenroll,$context);
     if ($result eq 'ok') {      if ($result eq 'ok') {
         &devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);          &devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);
     }      }
Line 5273  sub plaintext { Line 5388  sub plaintext {
 # ----------------------------------------------------------------- Assign Role  # ----------------------------------------------------------------- Assign Role
   
 sub assignrole {  sub assignrole {
     my ($udom,$uname,$url,$role,$end,$start,$deleteflag)=@_;      my ($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll,
           $context)=@_;
     my $mrole;      my $mrole;
     if ($role =~ /^cr\//) {      if ($role =~ /^cr\//) {
         my $cwosec=$url;          my $cwosec=$url;
Line 5307  sub assignrole { Line 5423  sub assignrole {
             } else {              } else {
                 $refused = 1;                  $refused = 1;
             }              }
             if ($refused) {               if ($refused) {
                 &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.                  if (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
                          ' '.$role.' '.$end.' '.$start.' by '.                      $refused = '';
            $env{'user.name'}.' at '.$env{'user.domain'});                  } else {
                 return 'refused';                      &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.
                                ' '.$role.' '.$end.' '.$start.' by '.
                  $env{'user.name'}.' at '.$env{'user.domain'});
                       return 'refused';
                   }
             }              }
         }          }
         $mrole=$role;          $mrole=$role;
Line 5328  sub assignrole { Line 5448  sub assignrole {
     }      }
     my $origstart = $start;      my $origstart = $start;
     my $origend = $end;      my $origend = $end;
       my $delflag;
 # actually delete  # actually delete
     if ($deleteflag) {      if ($deleteflag) {
  if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) {   if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) {
Line 5338  sub assignrole { Line 5459  sub assignrole {
 # set start and finish to negative values for userrolelog  # set start and finish to negative values for userrolelog
            $start=-1;             $start=-1;
            $end=-1;             $end=-1;
              $delflag = 1;
         }          }
     }      }
 # send command  # send command
Line 5346  sub assignrole { Line 5468  sub assignrole {
     if ($answer eq 'ok') {      if ($answer eq 'ok') {
  &userrolelog($role,$uname,$udom,$url,$start,$end);   &userrolelog($role,$uname,$udom,$url,$start,$end);
 # for course roles, perform group memberships changes triggered by role change.  # for course roles, perform group memberships changes triggered by role change.
           &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,$selfenroll,$context);
         unless ($role =~ /^gr/) {          unless ($role =~ /^gr/) {
             &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,              &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,
                                              $origstart);                                               $origstart,$selfenroll,$context);
         }          }
     }      }
     return $answer;      return $answer;
Line 5485  sub modifyuser { Line 5608  sub modifyuser {
   
 sub modifystudent {  sub modifystudent {
     my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,      my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
         $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid)=@_;          $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid,
           $selfenroll,$context)=@_;
     if (!$cid) {      if (!$cid) {
  unless ($cid=$env{'request.course.id'}) {   unless ($cid=$env{'request.course.id'}) {
     return 'not_in_class';      return 'not_in_class';
Line 5500  sub modifystudent { Line 5624  sub modifystudent {
     # students environment      # students environment
     $uid = undef if (!$forceid);      $uid = undef if (!$forceid);
     $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,      $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
  $gene,$usec,$end,$start,$type,$locktype,$cid);   $gene,$usec,$end,$start,$type,$locktype,$cid,$selfenroll,$context);
     return $reply;      return $reply;
 }  }
   
 sub modify_student_enrollment {  sub modify_student_enrollment {
     my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid) = @_;      my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid,$selfenroll,$context) = @_;
     my ($cdom,$cnum,$chome);      my ($cdom,$cnum,$chome);
     if (!$cid) {      if (!$cid) {
  unless ($cid=$env{'request.course.id'}) {   unless ($cid=$env{'request.course.id'}) {
Line 5563  sub modify_student_enrollment { Line 5687  sub modify_student_enrollment {
     if ($usec) {      if ($usec) {
  $uurl.='/'.$usec;   $uurl.='/'.$usec;
     }      }
     return &assignrole($udom,$uname,$uurl,'st',$end,$start);      return &assignrole($udom,$uname,$uurl,'st',$end,$start,undef,$selfenroll,$context);
 }  }
   
 sub format_name {  sub format_name {
Line 5682  ENDINITMAP Line 5806  ENDINITMAP
 sub is_course {  sub is_course {
     my ($cdom,$cnum) = @_;      my ($cdom,$cnum) = @_;
     my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,      my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,
  undef,'.',undef,1);   undef,'.');
     if (exists($courses{$cdom.'_'.$cnum})) {      if (exists($courses{$cdom.'_'.$cnum})) {
         return 1;          return 1;
     }      }
Line 5692  sub is_course { Line 5816  sub is_course {
 # ---------------------------------------------------------- Assign Custom Role  # ---------------------------------------------------------- Assign Custom Role
   
 sub assigncustomrole {  sub assigncustomrole {
     my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag)=@_;      my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag,$selfenroll,$context)=@_;
     return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,      return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,
                        $end,$start,$deleteflag);                         $end,$start,$deleteflag,$selfenroll,$context);
 }  }
   
 # ----------------------------------------------------------------- Revoke Role  # ----------------------------------------------------------------- Revoke Role
   
 sub revokerole {  sub revokerole {
     my ($udom,$uname,$url,$role,$deleteflag)=@_;      my ($udom,$uname,$url,$role,$deleteflag,$selfenroll,$context)=@_;
     my $now=time;      my $now=time;
     return &assignrole($udom,$uname,$url,$role,$now,$deleteflag);      return &assignrole($udom,$uname,$url,$role,$now,$deleteflag,$selfenroll,$context);
 }  }
   
 # ---------------------------------------------------------- Revoke Custom Role  # ---------------------------------------------------------- Revoke Custom Role
   
 sub revokecustomrole {  sub revokecustomrole {
     my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag)=@_;      my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag,$selfenroll,$context)=@_;
     my $now=time;      my $now=time;
     return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now,      return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now,
            $deleteflag);             $deleteflag,$selfenroll,$context);
 }  }
   
 # ------------------------------------------------------------ Disk usage  # ------------------------------------------------------------ Disk usage
 sub diskusage {  sub diskusage {
     my ($udom,$uname,$directoryRoot)=@_;      my ($udom,$uname,$directorypath,$getpropath)=@_;
     $directoryRoot =~ s/\/$//;      $directorypath =~ s/\/$//;
     my $listing=&reply('du:'.$directoryRoot,homeserver($uname,$udom));      my $listing=&reply('du2:'.&escape($directorypath).':'
                          .&escape($getpropath).':'.&escape($uname).':'
                          .&escape($udom),homeserver($uname,$udom));
       if ($listing eq 'unknown_cmd') {
           if ($getpropath) {
               $directorypath = &propath($udom,$uname).'/'.$directorypath; 
           }
           $listing = &reply('du:'.$directorypath,homeserver($uname,$udom));
       }
     return $listing;      return $listing;
 }  }
   
Line 6135  sub unmark_as_readonly { Line 6267  sub unmark_as_readonly {
 # ------------------------------------------------------------ Directory lister  # ------------------------------------------------------------ Directory lister
   
 sub dirlist {  sub dirlist {
     my ($uri,$userdomain,$username,$alternateDirectoryRoot)=@_;      my ($uri,$userdomain,$username,$getpropath,$getuserdir,$alternateRoot)=@_;
   
     $uri=~s/^\///;      $uri=~s/^\///;
     $uri=~s/\/$//;      $uri=~s/\/$//;
     my ($udom, $uname);      my ($udom, $uname);
     (undef,$udom,$uname)=split(/\//,$uri);      if ($getuserdir) {
     if(defined($userdomain)) {  
         $udom = $userdomain;          $udom = $userdomain;
     }  
     if(defined($username)) {  
         $uname = $username;          $uname = $username;
       } else {
           (undef,$udom,$uname)=split(/\//,$uri);
           if(defined($userdomain)) {
               $udom = $userdomain;
           }
           if(defined($username)) {
               $uname = $username;
           }
     }      }
       my ($dirRoot,$listing,@listing_results);
   
     my $dirRoot = $perlvar{'lonDocRoot'};      $dirRoot = $perlvar{'lonDocRoot'};
     if(defined($alternateDirectoryRoot)) {      if (defined($getpropath)) {
         $dirRoot = $alternateDirectoryRoot;          $dirRoot = &propath($udom,$uname);
         $dirRoot =~ s/\/$//;          $dirRoot =~ s/\/$//;
       } elsif (defined($getuserdir)) {
           my $subdir=$uname.'__';
           $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
           $dirRoot = $Apache::lonnet::perlvar{'lonUsersDir'}
                      ."/$udom/$subdir/$uname";
       } elsif (defined($alternateRoot)) {
           $dirRoot = $alternateRoot;
     }      }
   
     if($udom) {      if($udom) {
         if($uname) {          if($uname) {
             my $listing = &reply('ls2:'.$dirRoot.'/'.$uri,              $listing = &reply('ls3:'.&escape('/'.$uri).':'.$getpropath.':'
  &homeserver($uname,$udom));                                .$getuserdir.':'.&escape($dirRoot)
             my @listing_results;                                .':'.&escape($uname).':'.&escape($udom),
                                 &homeserver($uname,$udom));
               if ($listing eq 'unknown_cmd') {
                   $listing = &reply('ls2:'.$dirRoot.'/'.$uri,
                                     &homeserver($uname,$udom));
               } else {
                   @listing_results = map { &unescape($_); } split(/:/,$listing);
               }
             if ($listing eq 'unknown_cmd') {              if ($listing eq 'unknown_cmd') {
                 $listing = &reply('ls:'.$dirRoot.'/'.$uri,                  $listing = &reply('ls:'.$dirRoot.'/'.$uri,
   &homeserver($uname,$udom));    &homeserver($uname,$udom));
Line 6167  sub dirlist { Line 6318  sub dirlist {
                 @listing_results = map { &unescape($_); } split(/:/,$listing);                  @listing_results = map { &unescape($_); } split(/:/,$listing);
             }              }
             return @listing_results;              return @listing_results;
         } elsif(!defined($alternateDirectoryRoot)) {          } elsif(!$alternateRoot) {
             my %allusers;              my %allusers;
     my %servers = &get_servers($udom,'library');      my %servers = &get_servers($udom,'library');
     foreach my $tryserver (keys(%servers)) {       foreach my $tryserver (keys(%servers)) {
  my $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'.                  $listing = &reply('ls3:'.&escape("/res/$udom").':::::'.
      $udom, $tryserver);                                    &escape($udom),$tryserver);
  my @listing_results;                  if ($listing eq 'unknown_cmd') {
       $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'.
         $udom, $tryserver);
                   } else {
                       @listing_results = map { &unescape($_); } split(/:/,$listing);
                   }
  if ($listing eq 'unknown_cmd') {   if ($listing eq 'unknown_cmd') {
     $listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.      $listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.
       $udom, $tryserver);        $udom, $tryserver);
Line 6200  sub dirlist { Line 6356  sub dirlist {
         } else {          } else {
             return ('missing user name');              return ('missing user name');
         }          }
     } elsif(!defined($alternateDirectoryRoot)) {      } elsif(!defined($getpropath)) {
         my @all_domains = sort(&all_domains());          my @all_domains = sort(&all_domains());
          foreach my $domain (@all_domains) {          foreach my $domain (@all_domains) {
              $domain = $perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain';              $domain = $perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain';
          }          }
          return @all_domains;          return @all_domains;
      } else {      } else {
         return ('missing domain');          return ('missing domain');
     }      }
 }  }
Line 6216  sub dirlist { Line 6372  sub dirlist {
 # when it was last modified.  It will also return an error of -1  # when it was last modified.  It will also return an error of -1
 # if an error occurs  # if an error occurs
   
 ##  
 ## FIXME: This subroutine assumes its caller knows something about the  
 ## directory structure of the home server for the student ($root).  
 ## Not a good assumption to make.  Since this is for looking up files  
 ## in user directories, the full path should be constructed by lond, not  
 ## whatever machine we request data from.  
 ##  
 sub GetFileTimestamp {  sub GetFileTimestamp {
     my ($studentDomain,$studentName,$filename,$root)=@_;      my ($studentDomain,$studentName,$filename,$getuserdir)=@_;
     $studentDomain = &LONCAPA::clean_domain($studentDomain);      $studentDomain = &LONCAPA::clean_domain($studentDomain);
     $studentName   = &LONCAPA::clean_username($studentName);      $studentName   = &LONCAPA::clean_username($studentName);
     my $subdir=$studentName.'__';      my ($fileStat) = 
     $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;          &Apache::lonnet::dirlist($filename,$studentDomain,$studentName, 
     my $proname="$studentDomain/$subdir/$studentName";                                   undef,$getuserdir);
     $proname .= '/'.$filename;  
     my ($fileStat) = &Apache::lonnet::dirlist($proname, $studentDomain,   
                                               $studentName, $root);  
     my @stats = split('&', $fileStat);      my @stats = split('&', $fileStat);
     if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {      if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
         # @stats contains first the filename, then the stat output          # @stats contains first the filename, then the stat output
Line 6246  sub stat_file { Line 6392  sub stat_file {
     my ($uri) = @_;      my ($uri) = @_;
     $uri = &clutter_with_no_wrapper($uri);      $uri = &clutter_with_no_wrapper($uri);
   
     my ($udom,$uname,$file,$dir);      my ($udom,$uname,$file);
     if ($uri =~ m-^/(uploaded|editupload)/-) {      if ($uri =~ m-^/(uploaded|editupload)/-) {
  ($udom,$uname,$file) =   ($udom,$uname,$file) =
     ($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_name)/?(.*)-);      ($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_name)/?(.*)-);
  $file = 'userfiles/'.$file;   $file = 'userfiles/'.$file;
  $dir = &propath($udom,$uname);  
     }      }
     if ($uri =~ m-^/res/-) {      if ($uri =~ m-^/res/-) {
  ($udom,$uname) =    ($udom,$uname) = 
Line 6263  sub stat_file { Line 6408  sub stat_file {
  # unable to handle the uri   # unable to handle the uri
  return ();   return ();
     }      }
       my $getpropath;
     my ($result) = &dirlist($file,$udom,$uname,$dir);      if ($file =~ /^userfiles\//) {
           $getpropath = 1;
       }
       my ($result) = &dirlist($file,$udom,$uname,$getpropath);
     my @stats = split('&', $result);      my @stats = split('&', $result);
           
     if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {      if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
Line 6297  sub directcondval { Line 6445  sub directcondval {
     untie(%bighash);      untie(%bighash);
  }   }
  my $value = &docondval($sub_condition);   my $value = &docondval($sub_condition);
  &appenv('user.state.'.$env{'request.course.id'}.".$number" => $value);   &appenv({'user.state.'.$env{'request.course.id'}.".$number" => $value});
  return $value;   return $value;
     }      }
     if ($env{'user.state.'.$env{'request.course.id'}}) {      if ($env{'user.state.'.$env{'request.course.id'}}) {
Line 6483  sub EXT_cache_status { Line 6631  sub EXT_cache_status {
 sub EXT_cache_set {  sub EXT_cache_set {
     my ($target_domain,$target_user) = @_;      my ($target_domain,$target_user) = @_;
     my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;      my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;
     #&appenv($cachename => time);      #&appenv({$cachename => time});
 }  }
   
 # --------------------------------------------------------- Value of a Variable  # --------------------------------------------------------- Value of a Variable
Line 7385  sub symbread { Line 7533  sub symbread {
         if ($syval) {          if ($syval) {
     #unless ($syval=~/\_\d+$/) {      #unless ($syval=~/\_\d+$/) {
  #unless ($env{'form.request.prefix'}=~/\.(\d+)\_$/) {   #unless ($env{'form.request.prefix'}=~/\.(\d+)\_$/) {
     #&appenv('request.ambiguous' => $thisfn);      #&appenv({'request.ambiguous' => $thisfn});
     #return $env{$cache_str}='';      #return $env{$cache_str}='';
  #}       #}    
  #$syval.=$1;   #$syval.=$1;
Line 7437  sub symbread { Line 7585  sub symbread {
     return $env{$cache_str}=$syval;      return $env{$cache_str}=$syval;
         }          }
     }      }
     &appenv('request.ambiguous' => $thisfn);      &appenv({'request.ambiguous' => $thisfn});
     return $env{$cache_str}='';      return $env{$cache_str}='';
 }  }
   
Line 7951  sub tokenwrapper { Line 8099  sub tokenwrapper {
     my (undef,$udom,$uname,$file)=split('/',$uri,4);      my (undef,$udom,$uname,$file)=split('/',$uri,4);
     if ($udom && $uname && $file) {      if ($udom && $uname && $file) {
  $file=~s|(\?\.*)*$||;   $file=~s|(\?\.*)*$||;
         &appenv("userfile.$udom/$uname/$file" => $env{'request.course.id'});          &appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}});
         return 'http://'.&hostname(&homeserver($uname,$udom)).'/'.$uri.          return 'http://'.&hostname(&homeserver($uname,$udom)).'/'.$uri.
                (($uri=~/\?/)?'&':'?').'token='.$token.                 (($uri=~/\?/)?'&':'?').'token='.$token.
                                '&tokenissued='.$perlvar{'lonHostID'};                                 '&tokenissued='.$perlvar{'lonHostID'};
Line 8009  sub filelocation { Line 8157  sub filelocation {
     } elsif ($file=~m{^/home/$match_username/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 =~ m-^\Q$Apache::lonnet::perlvar{'lonTabDir'}\E/-) {
           $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)/+($match_domain)/+($match_name)/+(.*)$-);       ($file=~m -^/+(?:uploaded|editupload)/+($match_domain)/+($match_name)/+(.*)$-);
Line 8017  sub filelocation { Line 8167  sub filelocation {
         my @ids=&current_machine_ids();          my @ids=&current_machine_ids();
         foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }          foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }
         if ($is_me) {          if ($is_me) {
      $location=&propath($udom,$uname).       $location=&propath($udom,$uname).'/userfiles/'.$filename;
        '/userfiles/'.$filename;  
         } else {          } else {
    $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.     $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
        $udom.'/'.$uname.'/'.$filename;         $udom.'/'.$uname.'/'.$filename;
Line 8796  that was requested Line 8945  that was requested
   
 =item *   =item * 
 X<appenv()>  X<appenv()>
 B<appenv(%hash)>: the value of %hash is written to  B<appenv($hashref,$rolesarrayref)>: the value of %{$hashref} is written to
 the user envirnoment file, and will be restored for each access this  the user envirnoment file, and will be restored for each access this
 user makes during this session, also modifies the %env for the current  user makes during this session, also modifies the %env for the current
 process  process. Optional rolesarrayref - if defined contains a reference to an array
   of roles which are exempt from the restriction on modifying user.role entries 
   in the user's environment.db and in %env.    
   
 =item *  =item *
 X<delenv()>  X<delenv()>
Line 8929  provided for types, will default to retu Line 9080  provided for types, will default to retu
   
 =item *  =item *
   
 assignrole($udom,$uname,$url,$role,$end,$start) : assign role; give a role to a  assignrole($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll,$context) : assign role; give a role to a
 user for the level given by URL.  Optional start and end dates (leave empty  user for the level given by URL.  Optional start and end dates (leave empty
 string or zero for "no date")  string or zero for "no date")
   
Line 8953  modify user Line 9104  modify user
   
 modifystudent  modifystudent
   
 modify a students enrollment and identification information.  modify a student's enrollment and identification information.
 The course id is resolved based on the current users environment.    The course id is resolved based on the current users environment.  
 This means the envoking user must be a course coordinator or otherwise  This means the envoking user must be a course coordinator or otherwise
 associated with a course.  associated with a course.
Line 8965  Inputs: Line 9116  Inputs:
   
 =over 4  =over 4
   
 =item B<$udom> Students loncapa domain  =item B<$udom> Student's loncapa domain
   
 =item B<$uname> Students loncapa login name  =item B<$uname> Student's loncapa login name
   
 =item B<$uid> Students id/student number  =item B<$uid> Student's id/student number
   
 =item B<$umode> Students authentication mode  =item B<$umode> Student's authentication mode
   
 =item B<$upass> Students password  =item B<$upass> Student's password
   
 =item B<$first> Students first name  =item B<$first> Student's first name
   
 =item B<$middle> Students middle name  =item B<$middle> Student's middle name
   
 =item B<$last> Students last name  =item B<$last> Student's last name
   
 =item B<$gene> Students generation  =item B<$gene> Student's generation
   
 =item B<$usec> Students section in course  =item B<$usec> Student's section in course
   
 =item B<$end> Unix time of the roles expiration  =item B<$end> Unix time of the roles expiration
   
Line 8993  Inputs: Line 9144  Inputs:
   
 =item B<$desiredhome> server to use as home server for student  =item B<$desiredhome> server to use as home server for student
   
   =item B<$email> Student's permanent e-mail address
   
   =item B<$type> Type of enrollment (auto or manual)
   
   =item B<$locktype>
   
   =item B<$cid>
   
   =item B<$selfenroll>
   
   =item B<$context>
   
 =back  =back
   
 =item *  =item *
Line 9026  Inputs: Line 9189  Inputs:
   
 =item $start  =item $start
   
   =item $type
   
   =item $locktype
   
   =item $cid
   
   =item $selfenroll
   
   =item $context
   
 =back  =back
   
   
Line 9362  put_dom($namespace,$storehash,$udom,$uho Line 9535  put_dom($namespace,$storehash,$udom,$uho
 domain level either on specified domain server ($uhome) or primary domain   domain level either on specified domain server ($uhome) or primary domain 
 server ($udom and $uhome are optional)  server ($udom and $uhome are optional)
   
   =item * 
   
   get_domain_defaults($target_domain) : returns hash with defaults for
   authentication and language in the domain. Keys are: auth_def, auth_arg_def,
   lang_def; corresponsing values are authentication type (internal, krb4, krb5,
   or localauth), initial password or a kerberos realm, language (e.g., en-us).
   Values are retrieved from cache (if current), or from domain's configuration.db
   (if available), or lastly from values in lonTabs/dns_domain,tab, 
   or lonTabs/domain.tab. 
   
   %domdefaults = &get_auth_defaults($target_domain);
   
 =back  =back
   
 =head2 Network Status Functions  =head2 Network Status Functions

Removed from v.1.942  
changed lines
  Added in v.1.957


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