--- loncom/lonnet/perl/lonnet.pm 2007/11/10 03:51:10 1.923 +++ loncom/lonnet/perl/lonnet.pm 2008/04/16 22:59:36 1.955 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.923 2007/11/10 03:51:10 raeburn Exp $ +# $Id: lonnet.pm,v 1.955 2008/04/16 22:59:36 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -448,27 +448,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'; } @@ -513,7 +525,6 @@ sub get_env_multiple { } # ------------------------------------------ Find out current server userload -# there is a copy in lond sub userload { my $numusers=0; { @@ -521,7 +532,8 @@ sub userload { my $filename; my $curtime=time; while ($filename=readdir(LONIDS)) { - if ($filename eq '.' || $filename eq '..') {next;} + next if ($filename eq '.' || $filename eq '..'); + next if ($filename =~ /publicuser_\d+\.id/); my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9]; if ($curtime-$mtime < 1800) { $numusers++; } } @@ -693,24 +705,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"); @@ -1064,6 +1090,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 +1120,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 +1148,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 +1209,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 +1693,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*\>.*?$/$1/si; - return $output; + $output=~s/\<\/body\s*\>.*?$//si; + if (wantarray) { + return ($output, $response); + } else { + return $output; + } } # --------------------------------------------------------- Server Side Include @@ -1650,12 +1721,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 +1749,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 +1761,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 +1778,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 @@ -2200,10 +2287,10 @@ sub flushcourselogs { } } $courseidbuffer{$coursehombuf{$crsid}}{$crsid} = { - 'description' => &escape($coursedescrbuf{$crsid}), - 'inst_code' => &escape($courseinstcodebuf{$crsid}), - 'type' => &escape($coursetypebuf{$crsid}), - 'owner' => &escape($courseownerbuf{$crsid}), + 'description' => $coursedescrbuf{$crsid}, + 'inst_code' => $courseinstcodebuf{$crsid}, + 'type' => $coursetypebuf{$crsid}, + 'owner' => $courseownerbuf{$crsid}, }; } # @@ -2394,12 +2481,16 @@ sub userrolelog { } 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=(); foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) { - $nothide{join(':',split(/[\@\:]/,$user))}=1; + if ($user !~ /:/) { + $nothide{join(':',split(/[\@]/,$user))}=1; + } else { + $nothide{$user}=1; + } } my %returnhash=(); my %dumphash= @@ -2415,27 +2506,46 @@ 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; } sub get_my_roles { - my ($uname,$udom,$context,$types,$roles,$roledoms)=@_; + my ($uname,$udom,$context,$types,$roles,$roledoms,$withsec,$hidepriv)=@_; unless (defined($uname)) { $uname=$env{'user.name'}; } unless (defined($udom)) { $udom=$env{'user.domain'}; } - my %dumphash; + my (%dumphash,%nothide); if ($context eq 'userroles') { %dumphash = &dump('roles',$udom,$uname); } else { %dumphash= &dump('nohist_userroles',$udom,$uname); + if ($hidepriv) { + my %coursehash=&coursedescription($udom.'_'.$uname); + foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) { + if ($user !~ /:/) { + $nothide{join(':',split(/[\@]/,$user))} = 1; + } else { + $nothide{$user} = 1; + } + } + } } my %returnhash=(); my $now=time; @@ -2448,7 +2558,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)) { @@ -2486,7 +2596,18 @@ sub get_my_roles { } } } - $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend; + if ($hidepriv) { + if ((&privileged($username,$domain)) && + (!$nothide{$username.':'.$domain})) { + next; + } + } + if ($withsec) { + $returnhash{$username.':'.$domain.':'.$role.':'.$section} = + $tstart.':'.$tend; + } else { + $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend; + } } return %returnhash; } @@ -2550,7 +2671,7 @@ sub courseidput { foreach my $cid (keys(%$storehash)) { $what .= &escape($cid).'='; foreach my $item ('description','inst_code','owner','type') { - $what .= &escape($storehash->{$item}).':'; + $what .= &escape($storehash->{$cid}{$item}).':'; } $what =~ s/\:$/&/; } @@ -2563,7 +2684,8 @@ sub courseidput { sub courseiddump { my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter, - $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_; + $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok, + $selfenrollonly)=@_; my $as_hash = 1; my %returnhash; if (!$domfilter) { $domfilter=''; } @@ -2580,7 +2702,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),$tryserver); my @pairs=split(/\&/,$rep); foreach my $item (@pairs) { my ($key,$value)=split(/\=/,$item,2); @@ -2670,7 +2793,9 @@ sub get_first_access { my ($symb,$courseid,$udom,$uname)=&whichuser(); if ($argsymb) { $symb=$argsymb; } my ($map,$id,$res)=&decode_symb($symb); - if ($type eq 'map') { + if ($type eq 'course') { + $res='course'; + } elsif ($type eq 'map') { $res=&symbread($map); } else { $res=$symb; @@ -2683,7 +2808,9 @@ sub set_first_access { my ($type)=@_; my ($symb,$courseid,$udom,$uname)=&whichuser(); my ($map,$id,$res)=&decode_symb($symb); - if ($type eq 'map') { + if ($type eq 'course') { + $res='course'; + } elsif ($type eq 'map') { $res=&symbread($map); } else { $res=$symb; @@ -3313,7 +3440,7 @@ sub coursedescription { } } if (!$args->{'one_time'}) { - &appenv(%envhash); + &appenv(\%envhash); } return %returnhash; } @@ -3498,7 +3625,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); @@ -3862,6 +3989,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; @@ -4839,8 +4967,15 @@ sub auto_run { $response = 1; } } else { - my $homeserver = &homeserver($cnum,$cdom); - $response = &reply('autorun:'.$cdom,$homeserver); + my $homeserver; + if (&is_course($cdom,$cnum)) { + $homeserver = &homeserver($cnum,$cdom); + } else { + $homeserver = &domain($cdom,'primary'); + } + if ($homeserver ne 'no_host') { + $response = &reply('autorun:'.$cdom,$homeserver); + } } return $response; } @@ -5221,7 +5356,7 @@ sub plaintext { # ----------------------------------------------------------------- Assign Role sub assignrole { - my ($udom,$uname,$url,$role,$end,$start,$deleteflag)=@_; + my ($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll)=@_; my $mrole; if ($role =~ /^cr\//) { my $cwosec=$url; @@ -5246,11 +5381,25 @@ sub assignrole { } else { my $cwosec=$url; $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/; - unless ((&allowed('c'.$role,$cwosec)) || &allowed('c'.$role,$udom)) { - &logthis('Refused assignrole: '. - $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. - $env{'user.name'}.' at '.$env{'user.domain'}); - return 'refused'; + if (!(&allowed('c'.$role,$cwosec)) && !(&allowed('c'.$role,$udom))) { + my $refused; + if (($env{'request.course.sec'} ne '') && ($role eq 'st')) { + if (!(&allowed('c'.$role,$url))) { + $refused = 1; + } + } else { + $refused = 1; + } + 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; } @@ -5443,7 +5592,7 @@ sub modifystudent { } 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) = @_; my ($cdom,$cnum,$chome); if (!$cid) { unless ($cid=$env{'request.course.id'}) { @@ -5501,7 +5650,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); } sub format_name { @@ -5620,7 +5769,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; } @@ -5654,9 +5803,17 @@ sub revokecustomrole { # ------------------------------------------------------------ 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; } @@ -6073,30 +6230,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($alternateRoot) + .':'.&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)); @@ -6105,13 +6281,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); @@ -6138,13 +6319,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'); } } @@ -6154,23 +6335,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 @@ -6184,12 +6355,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) = @@ -6202,7 +6372,8 @@ sub stat_file { return (); } - my ($result) = &dirlist($file,$udom,$uname,$dir); + my $getpropath = 1; + my ($result) = &dirlist($file,$udom,$uname,$getpropath); my @stats = split('&', $result); if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') { @@ -6235,7 +6406,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'}}) { @@ -6392,8 +6563,8 @@ sub resdata { } if (!ref($result)) { return $result; } foreach my $item (@which) { - if (defined($result->{$item})) { - return $result->{$item}; + if (defined($result->{$item->[0]})) { + return [$result->{$item->[0]},$item->[1]]; } } return undef; @@ -6421,7 +6592,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 @@ -6605,24 +6776,27 @@ sub EXT { # ----------------------------------------------------------- first, check user my $userreply=&resdata($uname,$udom,'user', - ($courselevelr,$courselevelm, - $courselevel)); - if (defined($userreply)) { return $userreply; } + ([$courselevelr,'resource'], + [$courselevelm,'map' ], + [$courselevel, 'course' ])); + if (defined($userreply)) { return &get_reply($userreply); } # ------------------------------------------------ second, check some of course my $coursereply; if (@groups > 0) { $coursereply = &check_group_parms($courseid,\@groups,$symbparm, $mapparm,$spacequalifierrest); - if (defined($coursereply)) { return $coursereply; } + if (defined($coursereply)) { return &get_reply($coursereply); } } $coursereply=&resdata($env{'course.'.$courseid.'.num'}, - $env{'course.'.$courseid.'.domain'}, - 'course', - ($seclevelr,$seclevelm,$seclevel, - $courselevelr)); - if (defined($coursereply)) { return $coursereply; } + $env{'course.'.$courseid.'.domain'}, + 'course', + ([$seclevelr, 'resource'], + [$seclevelm, 'map' ], + [$seclevel, 'course' ], + [$courselevelr,'resource'])); + if (defined($coursereply)) { return &get_reply($coursereply); } # ------------------------------------------------------ third, check map parms my %parmhash=(); @@ -6633,7 +6807,7 @@ sub EXT { $thisparm=$parmhash{$symbparm}; untie(%parmhash); } - if ($thisparm) { return $thisparm; } + if ($thisparm) { return &get_reply([$thisparm,'resource']); } } # ------------------------------------------ fourth, look in resource metadata @@ -6646,18 +6820,19 @@ sub EXT { $filename=$env{'request.filename'}; } my $metadata=&metadata($filename,$spacequalifierrest); - if (defined($metadata)) { return $metadata; } + if (defined($metadata)) { return &get_reply([$metadata,'resource']); } $metadata=&metadata($filename,'parameter_'.$spacequalifierrest); - if (defined($metadata)) { return $metadata; } + if (defined($metadata)) { return &get_reply([$metadata,'resource']); } -# ---------------------------------------------- fourth, look in rest pf course +# ---------------------------------------------- fourth, look in rest of course if ($symbparm && defined($courseid) && $courseid eq $env{'request.course.id'}) { my $coursereply=&resdata($env{'course.'.$courseid.'.num'}, $env{'course.'.$courseid.'.domain'}, 'course', - ($courselevelm,$courselevel)); - if (defined($coursereply)) { return $coursereply; } + ([$courselevelm,'map' ], + [$courselevel, 'course'])); + if (defined($coursereply)) { return &get_reply($coursereply); } } # ------------------------------------------------------------------ Cascade up unless ($space eq '0') { @@ -6665,14 +6840,13 @@ sub EXT { my $id=pop(@parts); my $part=join('_',@parts); if ($part eq '') { $part='0'; } - my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, + my @partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, $symbparm,$udom,$uname,$section,1); - if (defined($partgeneral)) { return $partgeneral; } + if (defined($partgeneral[0])) { return &get_reply(\@partgeneral); } } if ($recurse) { return undef; } my $pack_def=&packages_tab_default($filename,$varname); - if (defined($pack_def)) { return $pack_def; } - + if (defined($pack_def)) { return &get_reply([$pack_def,'resource']); } # ---------------------------------------------------- Any other user namespace } elsif ($realm eq 'environment') { # ----------------------------------------------------------------- environment @@ -6700,15 +6874,27 @@ sub EXT { return ''; } +sub get_reply { + my ($reply_value) = @_; + if (ref($reply_value) eq 'ARRAY') { + if (wantarray) { + return @$reply_value; + } + return $reply_value->[0]; + } else { + return $reply_value; + } +} + sub check_group_parms { my ($courseid,$groups,$symbparm,$mapparm,$what) = @_; my @groupitems = (); my $resultitem; - my @levels = ($symbparm,$mapparm,$what); + my @levels = ([$symbparm,'resource'],[$mapparm,'map'],[$what,'course']); foreach my $group (@{$groups}) { foreach my $level (@levels) { - my $item = $courseid.'.['.$group.'].'.$level; - push(@groupitems,$item); + my $item = $courseid.'.['.$group.'].'.$level->[0]; + push(@groupitems,[$item,$level->[1]]); } } my $coursereply = &resdata($env{'course.'.$courseid.'.num'}, @@ -6801,8 +6987,11 @@ sub metadata { if (($uri eq '') || (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) || - ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) || - ($uri =~ m|home/$match_username/public_html/|)) { + ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) ) { + return undef; + } + if (($uri =~ /^~/ || $uri =~ m{home/$match_username/public_html/}) + && &Apache::lonxml::get_state('target') =~ /^(|meta)$/) { return undef; } my $filename=$uri; @@ -6823,6 +7012,7 @@ sub metadata { # if (! exists($metacache{$uri})) { # $metacache{$uri}={}; # } + my $cachetime = 60*60; if ($liburi) { $liburi=&declutter($liburi); $filename=$liburi; @@ -6833,7 +7023,13 @@ sub metadata { my %metathesekeys=(); unless ($filename=~/\.meta$/) { $filename.='.meta'; } my $metastring; - if ($uri !~ m -^(editupload)/-) { + if ($uri =~ /^~/ || $uri =~ m{home/$match_username/public_html/}) { + my $which = &hreflocation('','/'.($liburi || $uri)); + $metastring = + &Apache::lonnet::ssi_body($which, + ('grade_target' => 'meta')); + $cachetime = 1; # only want this cached in the child not long term + } elsif ($uri !~ m -^(editupload)/-) { my $file=&filelocation('',&clutter($filename)); #push(@{$metaentry{$uri.'.file'}},$file); $metastring=&getfile($file); @@ -7000,7 +7196,7 @@ sub metadata { $metaentry{':keys'} = join(',',keys(%metathesekeys)); &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri); $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys); - &do_cache_new('meta',$uri,\%metaentry,60*60); + &do_cache_new('meta',$uri,\%metaentry,$cachetime); # this is the end of "was not already recently cached } return $metaentry{':'.$what}; @@ -7298,7 +7494,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; @@ -7350,7 +7546,7 @@ sub symbread { return $env{$cache_str}=$syval; } } - &appenv('request.ambiguous' => $thisfn); + &appenv({'request.ambiguous' => $thisfn}); return $env{$cache_str}=''; } @@ -7864,7 +8060,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'}; @@ -7930,8 +8126,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; @@ -7948,7 +8143,13 @@ sub filelocation { } } $location=~s://+:/:g; # remove duplicate / - while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/.. + while ($location=~m{/\.\./}) { + if ($location =~ m{/[^/]+/\.\./}) { + $location=~ s{/[^/]+/\.\./}{/}g; + } else { + $location=~ s{/\.\./}{/}g; + } + } #remove dir/.. while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./ return $location; } @@ -8703,10 +8904,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 @@ -8814,14 +9017,15 @@ explanation of a user role term =item * -get_my_roles($uname,$udom,$context,$types,$roles,$roledoms) : +get_my_roles($uname,$udom,$context,$types,$roles,$roledoms,$withsec) : All arguments are optional. Returns a hash of a roles, either for co-author/assistant author roles for a user's Construction Space (default), or if $context is 'userroles', roles for the user himself, -In the hash, keys are set to colon-sparated $uname,$udom,and $role, -and value is set to colon-separated start and end times for the role. -If no username and domain are specified, will default to current -user/domain. Types, roles, and roledoms are references to arrays, +In the hash, keys are set to colon-separated $uname,$udom,$role, and +(optionally) if $withsec is true, a fourth colon-separated item - $section. +For each key, value is set to colon-separated start and end times for +the role. If no username and domain are specified, will default to +current user/domain. Types, roles, and roledoms are references to arrays of role statuses (active, future or previous), roles (e.g., cc,in, st etc.) and domains of the roles which can be used to restrict the list of roles reported. If no array ref is @@ -9268,6 +9472,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