--- loncom/lonnet/perl/lonnet.pm 2007/07/20 23:16:19 1.898 +++ loncom/lonnet/perl/lonnet.pm 2008/02/21 10:04:35 1.942 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.898 2007/07/20 23:16:19 albertel Exp $ +# $Id: lonnet.pm,v 1.942 2008/02/21 10:04:35 foxr Exp $ # # Copyright Michigan State University Board of Trustees # @@ -320,7 +320,10 @@ sub convert_and_load_session_env { my ($lonidsdir,$handle)=@_; my @profile; { - open(my $idf,"$lonidsdir/$handle.id"); + my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id"); + if (!$opened) { + return 0; + } flock($idf,LOCK_SH); @profile=<$idf>; close($idf); @@ -359,7 +362,10 @@ sub transfer_profile_to_env { my $convert; { - open(my $idf,"$lonidsdir/$handle.id"); + my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id"); + if (!$opened) { + return; + } flock($idf,LOCK_SH); if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id", &GDBM_READER(),0640)) { @@ -391,6 +397,34 @@ sub transfer_profile_to_env { } } +# ---------------------------------------------------- Check for valid session +sub check_for_valid_session { + my ($r) = @_; + my %cookies=CGI::Cookie->parse($r->header_in('Cookie')); + my $lonid=$cookies{'lonID'}; + return undef if (!$lonid); + + my $handle=&LONCAPA::clean_handle($lonid->value); + my $lonidsdir=$r->dir_config('lonIDsDir'); + return undef if (!-e "$lonidsdir/$handle.id"); + + my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id"); + return undef if (!$opened); + + flock($idf,LOCK_SH); + my %disk_env; + if (!tie(%disk_env,'GDBM_File',"$lonidsdir/$handle.id", + &GDBM_READER(),0640)) { + return undef; + } + + if (!defined($disk_env{'user.name'}) + || !defined($disk_env{'user.domain'})) { + return undef; + } + return $handle; +} + sub timed_flock { my ($file,$lock_type) = @_; my $failed=0; @@ -425,8 +459,9 @@ sub appenv { $env{$key}=$newenv{$key}; } } - open(my $env_file,$env{'user.environment'}); - if (&timed_flock($env_file,LOCK_EX) + 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)) { @@ -446,16 +481,17 @@ sub delenv { "Attempt to delete from environment ".$delthis); return 'error'; } - open(my $env_file,$env{'user.environment'}); - if (&timed_flock($env_file,LOCK_EX) + 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)) { foreach my $key (keys(%disk_env)) { if ($key=~/^$delthis/) { - delete($env{$key}); - delete($disk_env{$key}); - } + delete($env{$key}); + delete($disk_env{$key}); + } } untie(%disk_env); } @@ -477,7 +513,6 @@ sub get_env_multiple { } # ------------------------------------------ Find out current server userload -# there is a copy in lond sub userload { my $numusers=0; { @@ -485,7 +520,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++; } } @@ -582,6 +618,27 @@ sub compare_server_load { } return ($spare_server,$lowest_load); } + +# --------------------------- ask offload servers if user already has a session +sub find_existing_session { + my ($udom,$uname) = @_; + foreach my $try_server (@{ $spareid{'primary'} }, + @{ $spareid{'default'} }) { + return $try_server if (&has_user_session($try_server, $udom, $uname)); + } + return; +} + +# -------------------------------- ask if server already has a session for user +sub has_user_session { + my ($lonid,$udom,$uname) = @_; + my $result = &reply(join(':','userhassession', + map {&escape($_)} ($udom,$uname)),$lonid); + return 1 if ($result eq 'ok'); + + return 0; +} + # --------------------------------------------- Try to change a user's password sub changepass { @@ -856,6 +913,208 @@ sub is_domainimage { return; } +sub inst_directory_query { + my ($srch) = @_; + my $udom = $srch->{'srchdomain'}; + my %results; + my $homeserver = &domain($udom,'primary'); + my $outcome; + if ($homeserver ne '') { + my $queryid=&reply("querysend:instdirsearch:". + &escape($srch->{'srchby'}).':'. + &escape($srch->{'srchterm'}).':'. + &escape($srch->{'srchtype'}),$homeserver); + my $host=&hostname($homeserver); + if ($queryid !~/^\Q$host\E\_/) { + &logthis('instituional directory search invalid queryid: '.$queryid.' for host: '.$homeserver.'in domain '.$udom); + return; + } + my $response = &get_query_reply($queryid); + my $maxtries = 5; + my $tries = 1; + while (($response=~/^timeout/) && ($tries < $maxtries)) { + $response = &get_query_reply($queryid); + $tries ++; + } + + if (!&error($response) && $response ne 'refused') { + if ($response eq 'unavailable') { + $outcome = $response; + } else { + $outcome = 'ok'; + my @matches = split(/\n/,$response); + foreach my $match (@matches) { + my ($key,$value) = split(/=/,$match); + $results{&unescape($key).':'.$udom} = &thaw_unescape($value); + } + } + } + } + return ($outcome,%results); +} + +sub usersearch { + my ($srch) = @_; + my $dom = $srch->{'srchdomain'}; + my %results; + my %libserv = &all_library(); + my $query = 'usersearch'; + foreach my $tryserver (keys(%libserv)) { + if (&host_domain($tryserver) eq $dom) { + my $host=&hostname($tryserver); + my $queryid= + &reply("querysend:".&escape($query).':'. + &escape($srch->{'srchby'}).':'. + &escape($srch->{'srchtype'}).':'. + &escape($srch->{'srchterm'}),$tryserver); + if ($queryid !~/^\Q$host\E\_/) { + &logthis('usersearch: invalid queryid: '.$queryid.' for host: '.$host.'in domain '.$dom.' and server: '.$tryserver); + next; + } + my $reply = &get_query_reply($queryid); + my $maxtries = 1; + my $tries = 1; + while (($reply=~/^timeout/) && ($tries < $maxtries)) { + $reply = &get_query_reply($queryid); + $tries ++; + } + if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) { + &logthis('usersrch error: '.$reply.' for '.$dom.' - searching for : '.$srch->{'srchterm'}.' by '.$srch->{'srchby'}.' ('.$srch->{'srchtype'}.') - maxtries: '.$maxtries.' tries: '.$tries); + } else { + my @matches; + if ($reply =~ /\n/) { + @matches = split(/\n/,$reply); + } else { + @matches = split(/\&/,$reply); + } + foreach my $match (@matches) { + my ($uname,$udom,%userhash); + foreach my $entry (split(/:/,$match)) { + my ($key,$value) = + map {&unescape($_);} split(/=/,$entry); + $userhash{$key} = $value; + if ($key eq 'username') { + $uname = $value; + } elsif ($key eq 'domain') { + $udom = $value; + } + } + $results{$uname.':'.$udom} = \%userhash; + } + } + } + } + return %results; +} + +sub get_instuser { + my ($udom,$uname,$id) = @_; + my $homeserver = &domain($udom,'primary'); + my ($outcome,%results); + if ($homeserver ne '') { + my $queryid=&reply("querysend:getinstuser:".&escape($uname).':'. + &escape($id).':'.&escape($udom),$homeserver); + my $host=&hostname($homeserver); + if ($queryid !~/^\Q$host\E\_/) { + &logthis('get_instuser invalid queryid: '.$queryid.' for host: '.$homeserver.'in domain '.$udom); + return; + } + my $response = &get_query_reply($queryid); + my $maxtries = 5; + my $tries = 1; + while (($response=~/^timeout/) && ($tries < $maxtries)) { + $response = &get_query_reply($queryid); + $tries ++; + } + if (!&error($response) && $response ne 'refused') { + if ($response eq 'unavailable') { + $outcome = $response; + } else { + $outcome = 'ok'; + my @matches = split(/\n/,$response); + foreach my $match (@matches) { + my ($key,$value) = split(/=/,$match); + $results{&unescape($key)} = &thaw_unescape($value); + } + } + } + } + my %userinfo; + if (ref($results{$uname}) eq 'HASH') { + %userinfo = %{$results{$uname}}; + } + return ($outcome,%userinfo); +} + +sub inst_rulecheck { + my ($udom,$uname,$id,$item,$rules) = @_; + my %returnhash; + if ($udom ne '') { + if (ref($rules) eq 'ARRAY') { + @{$rules} = map {&escape($_);} (@{$rules}); + my $rulestr = join(':',@{$rules}); + my $homeserver=&domain($udom,'primary'); + if (($homeserver ne '') && ($homeserver ne 'no_host')) { + my $response; + if ($item eq 'username') { + $response=&unescape(&reply('instrulecheck:'.&escape($udom). + ':'.&escape($uname).':'.$rulestr, + $homeserver)); + } elsif ($item eq 'id') { + $response=&unescape(&reply('instidrulecheck:'.&escape($udom). + ':'.&escape($id).':'.$rulestr, + $homeserver)); + } + if ($response ne 'refused') { + my @pairs=split(/\&/,$response); + foreach my $item (@pairs) { + my ($key,$value)=split(/=/,$item,2); + $key = &unescape($key); + next if ($key =~ /^error: 2 /); + $returnhash{$key}=&thaw_unescape($value); + } + } + } + } + } + return %returnhash; +} + +sub inst_userrules { + my ($udom,$check) = @_; + my (%ruleshash,@ruleorder); + if ($udom ne '') { + my $homeserver=&domain($udom,'primary'); + if (($homeserver ne '') && ($homeserver ne 'no_host')) { + my $response; + if ($check eq 'id') { + $response=&reply('instidrules:'.&escape($udom), + $homeserver); + } else { + $response=&reply('instuserrules:'.&escape($udom), + $homeserver); + } + if (($response ne 'refused') && ($response ne 'error') && + ($response ne 'unknown_cmd') && + ($response ne 'no_such_host')) { + my ($hashitems,$orderitems) = split(/:/,$response); + my @pairs=split(/\&/,$hashitems); + foreach my $item (@pairs) { + my ($key,$value)=split(/=/,$item,2); + $key = &unescape($key); + next if ($key =~ /^error: 2 /); + $ruleshash{$key}=&thaw_unescape($value); + } + my @esc_order = split(/\&/,$orderitems); + foreach my $item (@esc_order) { + push(@ruleorder,&unescape($item)); + } + } + } + } + return (\%ruleshash,\@ruleorder); +} + # --------------------------------------------------- Assign a key to a student sub assign_access_key { @@ -1132,17 +1391,21 @@ sub do_cache_new { $time=600; } if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); } - if (!($memcache->set($id,$setvalue,$time))) { + my $result = $memcache->set($id,$setvalue,$time); + if (! $result) { &logthis("caching of id -> $id failed"); + $memcache->disconnect_all(); } # need to make a copy of $value - #&make_room($id,$value,$debug); + &make_room($id,$value,$debug); return $value; } sub make_room { my ($id,$value,$debug)=@_; - $remembered{$id}=$value; + + $remembered{$id}= (ref($value)) ? &Storable::dclone($value) + : $value; if ($to_remember<0) { return; } $accessed{$id}=[&gettimeofday()]; if (scalar(keys(%remembered)) <= $to_remember) { return; } @@ -1372,7 +1635,7 @@ sub ssi_body { &ssi($filelink,%form)); $output=~s|//(\s*)?\s||gs; $output=~s/^.*?\]*\>//si; - $output=~s/(.*)\<\/body\s*\>.*?$/$1/si; + $output=~s/\<\/body\s*\>.*?$//si; return $output; } @@ -1387,9 +1650,21 @@ 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. +# 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: +# The content of the response. sub ssi { - my ($fn,%form)=@_; + my ($fn,%form, $r)=@_; my $ua=new LWP::UserAgent; @@ -1407,6 +1682,10 @@ sub ssi { $request->header(Cookie => $ENV{'HTTP_COOKIE'}); my $response=$ua->request($request); + if ($r) { + $$r = $response; + } + return $response->content; } @@ -1923,7 +2202,7 @@ sub flushcourselogs { # times and course titles for all courseids # my %courseidbuffer=(); - foreach my $crsid (keys %courselogs) { + foreach my $crsid (keys(%courselogs)) { if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'. &escape($courselogs{$crsid}), $coursehombuf{$crsid}) eq 'ok') { @@ -1936,23 +2215,21 @@ sub flushcourselogs { delete $courselogs{$crsid}; } } - if ($courseidbuffer{$coursehombuf{$crsid}}) { - $courseidbuffer{$coursehombuf{$crsid}}.='&'. - &escape($crsid).'='.&escape($coursedescrbuf{$crsid}). - ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid}); - } else { - $courseidbuffer{$coursehombuf{$crsid}}= - &escape($crsid).'='.&escape($coursedescrbuf{$crsid}). - ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid}); - } + $courseidbuffer{$coursehombuf{$crsid}}{$crsid} = { + 'description' => $coursedescrbuf{$crsid}, + 'inst_code' => $courseinstcodebuf{$crsid}, + 'type' => $coursetypebuf{$crsid}, + 'owner' => $courseownerbuf{$crsid}, + }; } # # Write course id database (reverse lookup) to homeserver of courses # Is used in pickcourse # foreach my $crs_home (keys(%courseidbuffer)) { - &courseidput(&host_domain($crs_home),$courseidbuffer{$crs_home}, - $crs_home); + my $response = &courseidput(&host_domain($crs_home), + $courseidbuffer{$crs_home}, + $crs_home,'timeonly'); } # # File accesses @@ -2008,7 +2285,7 @@ sub flushcourselogs { # my %domrolebuffer = (); foreach my $entry (keys %domainrolehash) { - my ($role,$uname,$udom,$runame,$rudom,$rsec)=split/:/,$entry; + my ($role,$uname,$udom,$runame,$rudom,$rsec)=split(/:/,$entry); if ($domrolebuffer{$rudom}) { $domrolebuffer{$rudom}.='&'.&escape($entry). '='.&escape($domainrolehash{$entry}); @@ -2130,7 +2407,6 @@ sub userrolelog { {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} = $tend.':'.$tstart; } - &flushcourselogs(); } sub get_course_adv_roles { @@ -2139,7 +2415,11 @@ sub get_course_adv_roles { 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= @@ -2167,15 +2447,25 @@ sub get_course_adv_roles { } 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; @@ -2188,7 +2478,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)) { @@ -2217,10 +2507,27 @@ sub get_my_roles { } if (ref($roles) eq 'ARRAY') { if (!grep(/^\Q$role\E$/,@{$roles})) { + if ($role =~ /^cr\//) { + if (!grep(/^cr$/,@{$roles})) { + next; + } + } else { + next; + } + } + } + if ($hidepriv) { + if ((&privileged($username,$domain)) && + (!$nothide{$username.':'.$domain})) { next; } } - $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend; + if ($withsec) { + $returnhash{$username.':'.$domain.':'.$role.':'.$section} = + $tstart.':'.$tend; + } else { + $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend; + } } return %returnhash; } @@ -2259,31 +2566,77 @@ sub getannounce { # sub courseidput { - my ($domain,$what,$coursehome)=@_; - return &reply('courseidput:'.$domain.':'.$what,$coursehome); + my ($domain,$storehash,$coursehome,$caller) = @_; + my $outcome; + if ($caller eq 'timeonly') { + my $cids = ''; + foreach my $item (keys(%$storehash)) { + $cids.=&escape($item).'&'; + } + $cids=~s/\&$//; + $outcome = &reply('courseidputhash:'.$domain.':'.$caller.':'.$cids, + $coursehome); + } else { + my $items = ''; + foreach my $item (keys(%$storehash)) { + $items.= &escape($item).'='. + &freeze_escape($$storehash{$item}).'&'; + } + $items=~s/\&$//; + $outcome = &reply('courseidputhash:'.$domain.':'.$caller.':'.$items, + $coursehome); + } + if ($outcome eq 'unknown_cmd') { + my $what; + foreach my $cid (keys(%$storehash)) { + $what .= &escape($cid).'='; + foreach my $item ('description','inst_code','owner','type') { + $what .= &escape($storehash->{$cid}{$item}).':'; + } + $what =~ s/\:$/&/; + } + $what =~ s/\&$//; + return &reply('courseidput:'.$domain.':'.$what,$coursehome); + } else { + return $outcome; + } } sub courseiddump { - my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_; - my %returnhash=(); - unless ($domfilter) { $domfilter=''; } + my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter, + $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_; + my $as_hash = 1; + my %returnhash; + if (!$domfilter) { $domfilter=''; } my %libserv = &all_library(); foreach my $tryserver (keys(%libserv)) { if ( ( $hostidflag == 1 && grep(/^\Q$tryserver\E$/,@{$hostidref}) ) || (!defined($hostidflag)) ) { - if ($domfilter eq '' - || (&host_domain($tryserver) eq $domfilter)) { - foreach my $line ( - split(/\&/,&reply('courseiddump:'.&host_domain($tryserver).':'. - $sincefilter.':'.&escape($descfilter).':'. - &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter).':'.&escape($regexp_ok), - $tryserver))) { - my ($key,$value)=split(/\=/,$line,2); - if (($key) && ($value)) { - $returnhash{&unescape($key)}=$value; - } + if (($domfilter eq '') || + (&host_domain($tryserver) eq $domfilter)) { + my $rep = + &reply('courseiddump:'.&host_domain($tryserver).':'. + $sincefilter.':'.&escape($descfilter).':'. + &escape($instcodefilter).':'.&escape($ownerfilter). + ':'.&escape($coursefilter).':'.&escape($typefilter). + ':'.&escape($regexp_ok).':'.$as_hash,$tryserver); + my @pairs=split(/\&/,$rep); + foreach my $item (@pairs) { + my ($key,$value)=split(/\=/,$item,2); + $key = &unescape($key); + next if ($key =~ /^error: 2 /); + my $result = &thaw_unescape($value); + if (ref($result) eq 'HASH') { + $returnhash{$key}=$result; + } else { + my @responses = split(/:/,$value); + my @items = ('description','inst_code','owner','type'); + for (my $i=0; $i<@responses; $i++) { + $returnhash{$key}{$items[$i]} = &unescape($responses[$i]); + } + } } } } @@ -2329,7 +2682,10 @@ sub get_domain_roles { if (undef($enddate) || $enddate eq '') { $enddate = '.'; } - my $rolelist = join(':',@{$roles}); + my $rolelist; + if (ref($roles) eq 'ARRAY') { + $rolelist = join(':',@{$roles}); + } my %personnel = (); my %servers = &get_servers($dom,'library'); @@ -2355,7 +2711,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; @@ -2368,7 +2726,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; @@ -3183,7 +3543,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); @@ -4375,6 +4735,23 @@ sub update_portfolio_table { return $reply; } +# -------------------------- Update MySQL allusers table + +sub update_allusers_table { + my ($uname,$udom,$names) = @_; + my $homeserver = &homeserver($uname,$udom); + my $queryid= + &reply('querysend:allusers:'.&escape($uname).':'.&escape($udom).':'. + 'lastname='.&escape($names->{'lastname'}).'%%'. + 'firstname='.&escape($names->{'firstname'}).'%%'. + 'middlename='.&escape($names->{'middlename'}).'%%'. + 'generation='.&escape($names->{'generation'}).'%%'. + 'permanentemail='.&escape($names->{'permanentemail'}).'%%'. + 'id='.&escape($names->{'id'}),$homeserver); + my $reply = &get_query_reply($queryid); + return $reply; +} + # ------- Request retrieval of institutional classlists for course(s) sub fetch_enrollment_query { @@ -4409,7 +4786,7 @@ sub fetch_enrollment_query { if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) { &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries); } else { - my @responses = split/:/,$reply; + my @responses = split(/:/,$reply); if ($homeserver eq $perlvar{'lonHostID'}) { foreach my $line (@responses) { my ($key,$value) = split(/=/,$line,2); @@ -4452,8 +4829,8 @@ sub get_query_reply { sleep 2; if (-e $replyfile.'.end') { if (open(my $fh,$replyfile)) { - $reply.=<$fh>; - close($fh); + $reply = join('',<$fh>); + close($fh); } else { return 'error: reply_file_error'; } return &unescape($reply); } @@ -4507,8 +4884,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; } @@ -4519,7 +4903,7 @@ sub auto_get_sections { my @secs = (); my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver)); unless ($response eq 'refused') { - @secs = split/:/,$response; + @secs = split(/:/,$response); } return @secs; } @@ -4558,7 +4942,7 @@ sub auto_create_password { if ($response eq 'refused') { $authchk = 'refused'; } else { - ($authparam,$create_passwd,$authchk) = split/:/,$response; + ($authparam,$create_passwd,$authchk) = split(/:/,$response); } } return ($authparam,$create_passwd,$authchk); @@ -4666,7 +5050,7 @@ sub auto_instcode_format { $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server); if ($response !~ /(con_lost|error|no_such_host|refused)/) { my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = - split/:/,$response; + split(/:/,$response); %{$codes} = (%{$codes},&str2hash($codes_str)); push(@{$codetitles},&str2array($codetitles_str)); %{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str)); @@ -4712,10 +5096,16 @@ sub auto_instcode_defaults { } sub auto_validate_class_sec { - my ($cdom,$cnum,$owner,$inst_class) = @_; + my ($cdom,$cnum,$owners,$inst_class) = @_; my $homeserver = &homeserver($cnum,$cdom); + my $ownerlist; + if (ref($owners) eq 'ARRAY') { + $ownerlist = join(',',@{$owners}); + } else { + $ownerlist = $owners; + } my $response=&reply('autovalidateclass_sec:'.$inst_class.':'. - &escape($owner).':'.$cdom,$homeserver); + &escape($ownerlist).':'.$cdom,$homeserver); return $response; } @@ -4908,11 +5298,21 @@ 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) { + &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url. + ' '.$role.' '.$end.' '.$start.' by '. + $env{'user.name'}.' at '.$env{'user.domain'}); + return 'refused'; + } } $mrole=$role; } @@ -5046,7 +5446,8 @@ sub modifyuser { } # -------------------------------------------------------------- Add names, etc my @tmp=&get('environment', - ['firstname','middlename','lastname','generation'], + ['firstname','middlename','lastname','generation','id', + 'permanentemail'], $udom,$uname); my %names; if ($tmp[0] =~ m/^error:.*/) { @@ -5068,8 +5469,10 @@ sub modifyuser { $names{'critnotification'} = $email; $names{'permanentemail'} = $email; } } + if ($uid) { $names{'id'} = $uid; } my $reply = &put('environment', \%names, $udom,$uname); if ($reply ne 'ok') { return 'error: '.$reply; } + my $sqlresult = &update_allusers_table($uname,$udom,\%names); &devalidate_cache_new('namescache',$uname.':'.$udom); &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '. $umode.', '.$first.', '.$middle.', '. @@ -5241,10 +5644,15 @@ sub createcourse { } # ----------------------------------------------------------------- Course made # log existence - &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description). - ':'.&escape($inst_code).':'.&escape($course_owner).':'. - &escape($crstype),$uhome); - &flushcourselogs(); + my $newcourse = { + $udom.'_'.$uname => { + description => $description, + inst_code => $inst_code, + owner => $course_owner, + type => $crstype, + }, + }; + &courseidput($udom,$newcourse,$uhome,'notime'); # set toplevel url my $topurl=$url; unless ($nonstandard) { @@ -5274,7 +5682,7 @@ ENDINITMAP sub is_course { my ($cdom,$cnum) = @_; my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef, - undef,'.'); + undef,'.',undef,1); if (exists($courses{$cdom.'_'.$cnum})) { return 1; } @@ -6046,8 +6454,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; @@ -6213,6 +6621,12 @@ sub EXT { my ($map) = &decode_symb($symbparm); return &symbread($map); } + if ($space eq 'filename') { + if ($symbparm) { + return &clutter((&decode_symb($symbparm))[2]); + } + return &hreflocation('',$env{'request.filename'}); + } my ($section, $group, @groups); my ($courselevelm,$courselevel); @@ -6253,24 +6667,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=(); @@ -6281,7 +6698,7 @@ sub EXT { $thisparm=$parmhash{$symbparm}; untie(%parmhash); } - if ($thisparm) { return $thisparm; } + if ($thisparm) { return &get_reply([$thisparm,'resource']); } } # ------------------------------------------ fourth, look in resource metadata @@ -6294,18 +6711,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') { @@ -6313,14 +6731,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 @@ -6348,15 +6765,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'}, @@ -6449,8 +6878,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; @@ -6471,6 +6903,7 @@ sub metadata { # if (! exists($metacache{$uri})) { # $metacache{$uri}={}; # } + my $cachetime = 60*60; if ($liburi) { $liburi=&declutter($liburi); $filename=$liburi; @@ -6481,7 +6914,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); @@ -6586,10 +7025,11 @@ sub metadata { # only ws inside the tag, and not in default, so use default # as value $metaentry{':'.$unikey}=$default; - } else { - # either something interesting inside the tag or default - # uninteresting + } elsif ( $internaltext =~ /\S/ ) { + # something interesting inside the tag $metaentry{':'.$unikey}=$internaltext; + } else { + # no interesting values, don't set a default } # end of not-a-package not-a-library import } @@ -6647,7 +7087,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}; @@ -6729,12 +7169,15 @@ sub gettitle { } my ($map,$resid,$url)=&decode_symb($symb); my $title=''; - my %bighash; - if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db', - &GDBM_READER(),0640)) { - my $mapid=$bighash{'map_pc_'.&clutter($map)}; - $title=$bighash{'title_'.$mapid.'.'.$resid}; - untie %bighash; + if (!$map && $resid == 0 && $url =~/default\.sequence$/) { + $title = $env{'course.'.$env{'request.course.id'}.'.description'}; + } else { + if (tie(my %bighash,'GDBM_File',$env{'request.course.fn'}.'.db', + &GDBM_READER(),0640)) { + my $mapid=$bighash{'map_pc_'.&clutter($map)}; + $title=$bighash{'title_'.$mapid.'.'.$resid}; + untie(%bighash); + } } $title=~s/\&colon\;/\:/gs; if ($title) { @@ -7592,7 +8035,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; } @@ -7613,6 +8062,9 @@ sub hreflocation { $file=~s-^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/ -/uploaded/$1/$2/-x; } + if ($file=~ m{^/userfiles/}) { + $file =~ s{^/userfiles/}{/uploaded/}; + } return $file; } @@ -8455,14 +8907,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 'user', 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, +(default), or if $context is 'userroles', roles for the user himself, +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