--- loncom/lonnet/perl/lonnet.pm 2008/01/18 02:18:07 1.938 +++ loncom/lonnet/perl/lonnet.pm 2008/06/06 04:53:51 1.960 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.938 2008/01/18 02:18:07 raeburn Exp $ +# $Id: lonnet.pm,v 1.960 2008/06/06 04:53:51 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -39,7 +39,7 @@ use vars qw(%perlvar %spareid %pr %prp $ my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash, %userrolehash, $processmarker, $dumpcount, %coursedombuf, %coursenumbuf, %coursehombuf, %coursedescrbuf, %courseinstcodebuf, - %courseownerbuf, %coursetypebuf); + %courseownerbuf, %coursetypebuf,$locknum); use IO::Socket; use GDBM_File; @@ -88,24 +88,26 @@ delayed. { my $logid; 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++; - my $id=time().'00000'.$$.'00000'.$logid; + my $now = time(); + my $id=$now.'00000'.$$.'00000'.$logid; return &Apache::lonnet::put('nohist_'.$hash_name, { $id => { 'exe_uname' => $env{'user.name'}, 'exe_udom' => $env{'user.domain'}, - 'exe_time' => time(), + 'exe_time' => $now, 'exe_ip' => $ENV{'REMOTE_ADDR'}, 'delflag' => $delflag, 'logentry' => $storehash, 'uname' => $uname, 'udom' => $udom, } - }, - $env{'course.'.$env{'request.course.id'}.'.domain'}, - $env{'course.'.$env{'request.course.id'}.'.num'} - ); + },$cdom,$cnum); } } @@ -448,27 +450,39 @@ sub timed_flock { # ---------------------------------------------------------- Append Environment sub appenv { - my %newenv=@_; - foreach my $key (keys(%newenv)) { - if (($newenv{$key}=~/^user\.role/) || ($newenv{$key}=~/^user\.priv/)) { - &logthis("WARNING: ". - "Attempt to modify environment ".$key." to ".$newenv{$key} - .''); - delete($newenv{$key}); - } else { - $env{$key}=$newenv{$key}; + my ($newenv,$roles) = @_; + if (ref($newenv) eq 'HASH') { + foreach my $key (keys(%{$newenv})) { + my $refused = 0; + if (($key =~ /^user\.role/) || ($key =~ /^user\.priv/)) { + $refused = 1; + if (ref($roles) eq 'ARRAY') { + my ($type,$role) = ($key =~ /^user\.(role|priv)\.([^.]+)\./); + if (grep(/^\Q$role\E$/,@{$roles})) { + $refused = 0; + } + } + } + if ($refused) { + &logthis("WARNING: ". + "Attempt to modify environment ".$key." to ".$newenv->{$key} + .''); + 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'; } @@ -512,6 +526,51 @@ sub get_env_multiple { return(@values); } +# ------------------------------------------------------------------- Locking + +sub set_lock { + my ($text)=@_; + $locknum++; + my $id=$$.'-'.$locknum; + &appenv({'session.locks' => $env{'session.locks'}.','.$id, + 'session.lock.'.$id => $text}); + return $id; +} + +sub get_locks { + my $num=0; + my %texts=(); + foreach my $lock (split(/\,/,$env{'session.locks'})) { + if ($lock=~/\w/) { + $num++; + $texts{$lock}=$env{'session.lock.'.$lock}; + } + } + return ($num,%texts); +} + +sub remove_lock { + my ($id)=@_; + my $newlocks=''; + foreach my $lock (split(/\,/,$env{'session.locks'})) { + if (($lock=~/\w/) && ($lock ne $id)) { + $newlocks.=','.$lock; + } + } + &appenv({'session.locks' => $newlocks}); + &delenv('session.lock.'.$id); +} + +sub remove_all_locks { + my $activelocks=$env{'session.locks'}; + foreach my $lock (split(/\,/,$env{'session.locks'})) { + if ($lock=~/\w/) { + &remove_lock($lock); + } + } +} + + # ------------------------------------------ Find out current server userload sub userload { my $numusers=0; @@ -693,24 +752,38 @@ sub queryauthenticate { # --------- Try to authenticate user from domain's lib servers (first this one) sub authenticate { - my ($uname,$upass,$udom)=@_; + my ($uname,$upass,$udom,$checkdefauth)=@_; $upass=&escape($upass); $uname= &LONCAPA::clean_username($uname); my $uhome=&homeserver($uname,$udom,1); + my $newhome; if ((!$uhome) || ($uhome eq 'no_host')) { # Maybe the machine was offline and only re-appeared again recently? &reconlonc(); # 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')) { &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') { - &logthis("User $uname at $udom authorized by $uhome"); - return $uhome; + if ($newhome) { + &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') { &logthis("User $uname at $udom rejected by $uhome"); @@ -885,6 +958,10 @@ sub retrieve_inst_usertypes { if (defined(&domain($udom,'primary'))) { my $uhome=&domain($udom,'primary'); my $rep=&reply("inst_usertypes:$udom",$uhome); + if ($rep =~ /^(con_lost|error|no_such_host|refused)/) { + &logthis("get_dom failed - $rep returned from $uhome in domain: $udom"); + return (\%returnhash,\@order); + } my ($hashitems,$orderitems) = split(/:/,$rep); my @pairs=split(/\&/,$hashitems); foreach my $item (@pairs) { @@ -1064,6 +1141,10 @@ sub inst_rulecheck { $response=&unescape(&reply('instidrulecheck:'.&escape($udom). ':'.&escape($id).':'.$rulestr, $homeserver)); + } elsif ($item eq 'selfcreate') { + $response=&unescape(&reply('instselfcreatecheck:'. + &escape($udom).':'.&escape($uname). + ':'.$rulestr,$homeserver)); } if ($response ne 'refused') { my @pairs=split(/\&/,$response); @@ -1090,6 +1171,9 @@ sub inst_userrules { if ($check eq 'id') { $response=&reply('instidrules:'.&escape($udom), $homeserver); + } elsif ($check eq 'email') { + $response=&reply('instemailrules:'.&escape($udom), + $homeserver); } else { $response=&reply('instuserrules:'.&escape($udom), $homeserver); @@ -1115,6 +1199,35 @@ sub inst_userrules { 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 sub assign_access_key { @@ -1147,7 +1260,7 @@ sub assign_access_key { # key now belongs to user my $envkey='key.'.$cdom.'_'.$cnum; if (&put('environment',{$envkey => $ckey}) eq 'ok') { - &appenv('environment.'.$envkey => $ckey); + &appenv({'environment.'.$envkey => $ckey}); return 'ok'; } else { return @@ -1631,12 +1744,21 @@ sub ssi_body { if (! exists($form{'LONCAPA_INTERNAL_no_discussion'})) { $form{'LONCAPA_INTERNAL_no_discussion'}='true'; } - my $output=($filelink=~/^http\:/?&externalssi($filelink): - &ssi($filelink,%form)); + my $output=''; + my $response; + if ($filelink=~/^http\:/) { + ($output,$response)=&externalssi($filelink); + } else { + ($output,$response)=&ssi($filelink,%form); + } $output=~s|//(\s*)?\s||gs; $output=~s/^.*?\]*\>//si; $output=~s/\<\/body\s*\>.*?$//si; - return $output; + if (wantarray) { + return ($output, $response); + } else { + return $output; + } } # --------------------------------------------------------- Server Side Include @@ -1650,12 +1772,20 @@ sub absolute_url { return $protocol.$host_name; } +# +# Server side include. +# Parameters: +# fn Possibly encrypted resource name/id. +# form Hash that describes how the rendering should be done +# and other things. +# Returns: +# Scalar context: The content of the response. +# Array context: 2 element list of the content and the full response object. +# sub ssi { my ($fn,%form)=@_; - my $ua=new LWP::UserAgent; - my $request; $form{'no_update_last_known'}=1; @@ -1670,7 +1800,11 @@ sub ssi { $request->header(Cookie => $ENV{'HTTP_COOKIE'}); my $response=$ua->request($request); - return $response->content; + if (wantarray) { + return ($response->content, $response); + } else { + return $response->content; + } } sub externalssi { @@ -1678,7 +1812,11 @@ sub externalssi { my $ua=new LWP::UserAgent; my $request=new HTTP::Request('GET',$url); 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 @@ -1691,7 +1829,7 @@ sub allowuploaded { my %httpref=(); my $httpurl=&hreflocation('',$url); $httpref{'httpref.'.$httpurl}=$srcurl; - &Apache::lonnet::appenv(%httpref); + &Apache::lonnet::appenv(\%httpref); } # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course @@ -2393,8 +2531,38 @@ 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 { - my $cid=shift; + my ($cid,$codes) = @_; $cid=$env{'request.course.id'} unless (defined($cid)); my %coursehash=&coursedescription($cid); my %nothide=(); @@ -2419,14 +2587,23 @@ sub get_course_adv_roles { if ((&privileged($username,$domain)) && (!$nothide{$username.':'.$domain})) { next; } if ($role eq 'cr') { next; } - my $key=&plaintext($role); - if ($section) { $key.=' (Sec/Grp '.$section.')'; } - if ($returnhash{$key}) { - $returnhash{$key}.=','.$username.':'.$domain; + if ($codes) { + if ($section) { $role .= ':'.$section; } + if ($returnhash{$role}) { + $returnhash{$role}.=','.$username.':'.$domain; + } else { + $returnhash{$role}=$username.':'.$domain; + } } 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; } @@ -2462,7 +2639,7 @@ sub get_my_roles { } if (($tstart) && ($tstart<0)) { next; } my $status = 'active'; - if (($tend) && ($tend<$now)) { + if (($tend) && ($tend<=$now)) { $status = 'previous'; } if (($tstart) && ($now<$tstart)) { @@ -2588,7 +2765,8 @@ sub courseidput { sub courseiddump { my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter, - $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_; + $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok, + $selfenrollonly,$catfilter)=@_; my $as_hash = 1; my %returnhash; if (!$domfilter) { $domfilter=''; } @@ -2605,7 +2783,8 @@ sub courseiddump { $sincefilter.':'.&escape($descfilter).':'. &escape($instcodefilter).':'.&escape($ownerfilter). ':'.&escape($coursefilter).':'.&escape($typefilter). - ':'.&escape($regexp_ok).':'.$as_hash,$tryserver); + ':'.&escape($regexp_ok).':'.$as_hash.':'. + &escape($selfenrollonly).':'.&escape($catfilter),$tryserver); my @pairs=split(/\&/,$rep); foreach my $item (@pairs) { my ($key,$value)=split(/\=/,$item,2); @@ -3342,7 +3521,7 @@ sub coursedescription { } } if (!$args->{'one_time'}) { - &appenv(%envhash); + &appenv(\%envhash); } return %returnhash; } @@ -3527,7 +3706,7 @@ sub set_userprivs { } foreach my $role (keys(%{$allroles})) { my %thesepriv; - if (($role=~/^au/) || ($role=~/^ca/)) { $author=1; } + if (($role=~/^au/) || ($role=~/^ca/) || ($role=~/^aa/)) { $author=1; } foreach my $item (split(/:/,$$allroles{$role})) { if ($item ne '') { my ($privilege,$restrictions)=split(/&/,$item); @@ -3891,6 +4070,7 @@ sub tmpget { my %returnhash; foreach my $item (split(/\&/,$rep)) { my ($key,$value)=split(/=/,$item); + next if ($key =~ /^error: 2 /); $returnhash{&unescape($key)}=&thaw_unescape($value); } return %returnhash; @@ -4358,7 +4538,6 @@ sub allowed { } # Full access at system, domain or course-wide level? Exit. - if ($thisallowed=~/F/) { return 'F'; } @@ -5137,11 +5316,11 @@ sub toggle_coursegroup_status { } 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 $role = 'gr/'.&escape($userprivs); 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') { &devalidate_getgroups_cache($udom,$uname,$cdom,$cnum); } @@ -5257,7 +5436,8 @@ sub plaintext { # ----------------------------------------------------------------- Assign Role sub assignrole { - my ($udom,$uname,$url,$role,$end,$start,$deleteflag)=@_; + my ($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll, + $context)=@_; my $mrole; if ($role =~ /^cr\//) { my $cwosec=$url; @@ -5291,11 +5471,15 @@ sub assignrole { } else { $refused = 1; } - if ($refused) { - &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url. - ' '.$role.' '.$end.' '.$start.' by '. - $env{'user.name'}.' at '.$env{'user.domain'}); - return 'refused'; + if ($refused) { + if (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { + $refused = ''; + } else { + &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url. + ' '.$role.' '.$end.' '.$start.' by '. + $env{'user.name'}.' at '.$env{'user.domain'}); + return 'refused'; + } } } $mrole=$role; @@ -5312,6 +5496,7 @@ sub assignrole { } my $origstart = $start; my $origend = $end; + my $delflag; # actually delete if ($deleteflag) { if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) { @@ -5322,6 +5507,7 @@ sub assignrole { # set start and finish to negative values for userrolelog $start=-1; $end=-1; + $delflag = 1; } } # send command @@ -5330,9 +5516,10 @@ sub assignrole { if ($answer eq 'ok') { &userrolelog($role,$uname,$udom,$url,$start,$end); # for course roles, perform group memberships changes triggered by role change. + &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,$selfenroll,$context); unless ($role =~ /^gr/) { &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend, - $origstart); + $origstart,$selfenroll,$context); } } return $answer; @@ -5469,7 +5656,8 @@ sub modifyuser { sub modifystudent { 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) { unless ($cid=$env{'request.course.id'}) { return 'not_in_class'; @@ -5484,12 +5672,12 @@ sub modifystudent { # students environment $uid = undef if (!$forceid); $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; } 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); if (!$cid) { unless ($cid=$env{'request.course.id'}) { @@ -5547,7 +5735,7 @@ sub modify_student_enrollment { if ($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 { @@ -5666,7 +5854,7 @@ ENDINITMAP sub is_course { my ($cdom,$cnum) = @_; my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef, - undef,'.',undef,1); + undef,'.'); if (exists($courses{$cdom.'_'.$cnum})) { return 1; } @@ -5676,33 +5864,41 @@ sub is_course { # ---------------------------------------------------------- Assign Custom Role 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, - $end,$start,$deleteflag); + $end,$start,$deleteflag,$selfenroll,$context); } # ----------------------------------------------------------------- Revoke Role sub revokerole { - my ($udom,$uname,$url,$role,$deleteflag)=@_; + my ($udom,$uname,$url,$role,$deleteflag,$selfenroll,$context)=@_; my $now=time; - return &assignrole($udom,$uname,$url,$role,$now,$deleteflag); + return &assignrole($udom,$uname,$url,$role,$now,$deleteflag,$selfenroll,$context); } # ---------------------------------------------------------- Revoke Custom Role sub revokecustomrole { - my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag)=@_; + my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag,$selfenroll,$context)=@_; my $now=time; return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now, - $deleteflag); + $deleteflag,$selfenroll,$context); } # ------------------------------------------------------------ Disk usage sub diskusage { - my ($udom,$uname,$directoryRoot)=@_; - $directoryRoot =~ s/\/$//; - my $listing=&reply('du:'.$directoryRoot,homeserver($uname,$udom)); + my ($udom,$uname,$directorypath,$getpropath)=@_; + $directorypath =~ s/\/$//; + 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; } @@ -6119,30 +6315,49 @@ sub unmark_as_readonly { # ------------------------------------------------------------ Directory lister sub dirlist { - my ($uri,$userdomain,$username,$alternateDirectoryRoot)=@_; - + my ($uri,$userdomain,$username,$getpropath,$getuserdir,$alternateRoot)=@_; $uri=~s/^\///; $uri=~s/\/$//; my ($udom, $uname); - (undef,$udom,$uname)=split(/\//,$uri); - if(defined($userdomain)) { + if ($getuserdir) { $udom = $userdomain; - } - if(defined($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'}; - if(defined($alternateDirectoryRoot)) { - $dirRoot = $alternateDirectoryRoot; + $dirRoot = $perlvar{'lonDocRoot'}; + if (defined($getpropath)) { + $dirRoot = &propath($udom,$uname); $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($uname) { - my $listing = &reply('ls2:'.$dirRoot.'/'.$uri, - &homeserver($uname,$udom)); - my @listing_results; + $listing = &reply('ls3:'.&escape('/'.$uri).':'.$getpropath.':' + .$getuserdir.':'.&escape($dirRoot) + .':'.&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') { $listing = &reply('ls:'.$dirRoot.'/'.$uri, &homeserver($uname,$udom)); @@ -6151,13 +6366,18 @@ sub dirlist { @listing_results = map { &unescape($_); } split(/:/,$listing); } return @listing_results; - } elsif(!defined($alternateDirectoryRoot)) { + } elsif(!$alternateRoot) { my %allusers; my %servers = &get_servers($udom,'library'); - foreach my $tryserver (keys(%servers)) { - my $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'. - $udom, $tryserver); - my @listing_results; + foreach my $tryserver (keys(%servers)) { + $listing = &reply('ls3:'.&escape("/res/$udom").':::::'. + &escape($udom),$tryserver); + 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') { $listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'. $udom, $tryserver); @@ -6184,13 +6404,13 @@ sub dirlist { } else { return ('missing user name'); } - } elsif(!defined($alternateDirectoryRoot)) { + } elsif(!defined($getpropath)) { my @all_domains = sort(&all_domains()); - foreach my $domain (@all_domains) { - $domain = $perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain'; - } - return @all_domains; - } else { + foreach my $domain (@all_domains) { + $domain = $perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain'; + } + return @all_domains; + } else { return ('missing domain'); } } @@ -6200,23 +6420,13 @@ sub dirlist { # when it was last modified. It will also return an error of -1 # 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 { - my ($studentDomain,$studentName,$filename,$root)=@_; + my ($studentDomain,$studentName,$filename,$getuserdir)=@_; $studentDomain = &LONCAPA::clean_domain($studentDomain); $studentName = &LONCAPA::clean_username($studentName); - my $subdir=$studentName.'__'; - $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; - my $proname="$studentDomain/$subdir/$studentName"; - $proname .= '/'.$filename; - my ($fileStat) = &Apache::lonnet::dirlist($proname, $studentDomain, - $studentName, $root); + my ($fileStat) = + &Apache::lonnet::dirlist($filename,$studentDomain,$studentName, + undef,$getuserdir); my @stats = split('&', $fileStat); if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') { # @stats contains first the filename, then the stat output @@ -6230,12 +6440,11 @@ sub stat_file { my ($uri) = @_; $uri = &clutter_with_no_wrapper($uri); - my ($udom,$uname,$file,$dir); + my ($udom,$uname,$file); if ($uri =~ m-^/(uploaded|editupload)/-) { ($udom,$uname,$file) = ($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_name)/?(.*)-); $file = 'userfiles/'.$file; - $dir = &propath($udom,$uname); } if ($uri =~ m-^/res/-) { ($udom,$uname) = @@ -6247,8 +6456,11 @@ sub stat_file { # unable to handle the uri return (); } - - my ($result) = &dirlist($file,$udom,$uname,$dir); + my $getpropath; + if ($file =~ /^userfiles\//) { + $getpropath = 1; + } + my ($result) = &dirlist($file,$udom,$uname,$getpropath); my @stats = split('&', $result); if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') { @@ -6281,7 +6493,7 @@ sub directcondval { untie(%bighash); } 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; } if ($env{'user.state.'.$env{'request.course.id'}}) { @@ -6467,7 +6679,7 @@ sub EXT_cache_status { sub EXT_cache_set { my ($target_domain,$target_user) = @_; my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain; - #&appenv($cachename => time); + #&appenv({$cachename => time}); } # --------------------------------------------------------- Value of a Variable @@ -6751,10 +6963,14 @@ sub EXT { sub get_reply { my ($reply_value) = @_; - if (wantarray) { - return @$reply_value; + if (ref($reply_value) eq 'ARRAY') { + if (wantarray) { + return @$reply_value; + } + return $reply_value->[0]; + } else { + return $reply_value; } - return $reply_value->[0]; } sub check_group_parms { @@ -7365,7 +7581,7 @@ sub symbread { if ($syval) { #unless ($syval=~/\_\d+$/) { #unless ($env{'form.request.prefix'}=~/\.(\d+)\_$/) { - #&appenv('request.ambiguous' => $thisfn); + #&appenv({'request.ambiguous' => $thisfn}); #return $env{$cache_str}=''; #} #$syval.=$1; @@ -7417,7 +7633,7 @@ sub symbread { return $env{$cache_str}=$syval; } } - &appenv('request.ambiguous' => $thisfn); + &appenv({'request.ambiguous' => $thisfn}); return $env{$cache_str}=''; } @@ -7931,7 +8147,7 @@ sub tokenwrapper { my (undef,$udom,$uname,$file)=split('/',$uri,4); if ($udom && $uname && $file) { $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. (($uri=~/\?/)?'&':'?').'token='.$token. '&tokenissued='.$perlvar{'lonHostID'}; @@ -7989,6 +8205,8 @@ sub filelocation { } elsif ($file=~m{^/home/$match_username/public_html/}) { # is a correct contruction space reference $location = $file; + } elsif ($file =~ m-^\Q$Apache::lonnet::perlvar{'lonTabDir'}\E/-) { + $location = $file; } elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file my ($udom,$uname,$filename)= ($file=~m -^/+(?:uploaded|editupload)/+($match_domain)/+($match_name)/+(.*)$-); @@ -7997,8 +8215,7 @@ sub filelocation { my @ids=¤t_machine_ids(); foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } } if ($is_me) { - $location=&propath($udom,$uname). - '/userfiles/'.$filename; + $location=&propath($udom,$uname).'/userfiles/'.$filename; } else { $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'. $udom.'/'.$uname.'/'.$filename; @@ -8594,6 +8811,7 @@ $memcache=new Cache::Memcached({'servers $processmarker='_'.time.'_'.$perlvar{'lonHostID'}; $dumpcount=0; +$locknum=0; &logtouch(); &logthis('INFO: Read configuration'); @@ -8776,10 +8994,12 @@ that was requested =item * X -B: the value of %hash is written to +B: the value of %{$hashref} is written to the user envirnoment file, and will be restored for each access this 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 * X @@ -8909,7 +9129,7 @@ provided for types, will default to retu =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 string or zero for "no date") @@ -8933,7 +9153,7 @@ modify user 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. This means the envoking user must be a course coordinator or otherwise associated with a course. @@ -8945,25 +9165,25 @@ Inputs: =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 @@ -8973,6 +9193,18 @@ Inputs: =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 =item * @@ -9006,6 +9238,16 @@ Inputs: =item $start +=item $type + +=item $locktype + +=item $cid + +=item $selfenroll + +=item $context + =back @@ -9342,6 +9584,18 @@ put_dom($namespace,$storehash,$udom,$uho domain level either on specified domain server ($uhome) or primary domain 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 =head2 Network Status Functions