--- loncom/lonnet/perl/lonnet.pm 2007/06/13 02:21:54 1.889 +++ loncom/lonnet/perl/lonnet.pm 2007/10/03 21:59:13 1.919 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.889 2007/06/13 02:21:54 albertel Exp $ +# $Id: lonnet.pm,v 1.919 2007/10/03 21:59:13 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -149,7 +149,7 @@ sub create_connection { Type => SOCK_STREAM, Timeout => 10); return 0 if (!$client); - print $client (join(':',$hostname,$lonid,&machine_ids($lonid))."\n"); + print $client (join(':',$hostname,$lonid,&machine_ids($hostname))."\n"); my $result = <$client>; chomp($result); return 1 if ($result eq 'done'); @@ -214,6 +214,24 @@ sub reply { # ----------------------------------------------------------- Send USR1 to lonc sub reconlonc { + my ($lonid) = @_; + my $hostname = &hostname($lonid); + if ($lonid) { + my $peerfile="$perlvar{'lonSockDir'}/$hostname"; + if ($hostname && -e $peerfile) { + &logthis("Trying to reconnect lonc for $lonid ($hostname)"); + my $client=IO::Socket::UNIX->new(Peer => $peerfile, + Type => SOCK_STREAM, + Timeout => 10); + if ($client) { + print $client ("reset_retries\n"); + my $answer=<$client>; + #reset just this one. + } + } + return; + } + &logthis("Trying to reconnect lonc"); my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid"; if (open(my $fh,"<$loncfile")) { @@ -302,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); @@ -341,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)) { @@ -373,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; @@ -407,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)) { @@ -428,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); } @@ -564,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 { @@ -838,6 +913,194 @@ 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,$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=&unescape(&reply('instrulecheck:'.&escape($udom).':'. + &escape($uname).':'.$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) = @_; + my (%ruleshash,@ruleorder); + if ($udom ne '') { + my $homeserver=&domain($udom,'primary'); + if (($homeserver ne '') && ($homeserver ne 'no_host')) { + my $response=&reply('instuserrules:'.&escape($udom), + $homeserver); + if (($response ne 'refused') && ($response ne 'error') && + ($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 { @@ -1114,17 +1377,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; } @@ -1378,7 +1645,7 @@ sub ssi { my $request; $form{'no_update_last_known'}=1; - + &Apache::lonenc::check_encrypt(\$fn); if (%form) { $request=new HTTP::Request('POST',&absolute_url().$fn); $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form)); @@ -1918,23 +2185,20 @@ 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' => &escape($coursedescrbuf{$crsid}), + 'instcode' => &escape($courseinstcodebuf{$crsid}), + 'type' => &escape($coursetypebuf{$crsid}), + 'owner' => &escape($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); } # # File accesses @@ -1990,7 +2254,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}); @@ -2095,6 +2359,14 @@ sub userrolelog { {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} =$tend.':'.$tstart; } + if (($env{'request.role'} =~ /dc\./) && + (($trole=~/^au/) || ($trole=~/^in/) || + ($trole=~/^cc/) || ($trole=~/^ep/) || + ($trole=~/^cr/) || ($trole=~/^ta/))) { + $userrolehash + {$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'} + =$tend.':'.$tstart; + } if (($trole=~/^dc/) || ($trole=~/^ad/) || ($trole=~/^li/) || ($trole=~/^li/) || ($trole=~/^au/) || ($trole=~/^dg/) || @@ -2232,31 +2504,65 @@ sub getannounce { # sub courseidput { - my ($domain,$what,$coursehome)=@_; - return &reply('courseidput:'.$domain.':'.$what,$coursehome); + my ($domain,$storehash,$coursehome)=@_; + my $items=''; + my $now = time; + foreach my $item (keys(%$storehash)) { + $storehash->{$item}{'lasttime'} = $now; + $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; + } + $items=~s/\&$//; + my $outcome = &reply('courseidputhash:'.$domain.':'.$items,$coursehome); + if ($outcome eq 'unknown_cmd') { + my $what; + foreach my $cid (keys(%$storehash)) { + $what .= &escape($cid).'='; + foreach my $item ('description','instcode','owner','type') { + $what .= $storehash->{$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 $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(/:/,$result); + my @items = ('description','instcode','owner','type'); + for (my $i=0; $i<@responses; $i++) { + $returnhash{$key}{$items[$i]} = $responses[$i]; + } + } } } } @@ -3786,26 +4092,40 @@ sub customaccess { $ucrs = &LONCAPA::clean_username($ucrs); my $access=0; foreach my $right (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) { - my ($effect,$realm,$role)=split(/\:/,$right); - if ($role) { - if ($role ne $urole) { next; } - } - foreach my $scope (split(/\s*\,\s*/,$realm)) { - my ($tdom,$tcrs,$tsec)=split(/\_/,$scope); - if ($tdom) { - if ($tdom ne $udom) { next; } - } - if ($tcrs) { - if ($tcrs ne $ucrs) { next; } - } - if ($tsec) { - if ($tsec ne $usec) { next; } - } - $access=($effect eq 'allow'); - last; - } - if ($realm eq '' && $role eq '') { - $access=($effect eq 'allow'); + my ($effect,$realm,$role,$type)=split(/\:/,$right); + if ($type eq 'user') { + foreach my $scope (split(/\s*\,\s*/,$realm)) { + my ($tdom,$tuname)=split(m{/},$scope); + if ($tdom) { + if ($tdom ne $env{'user.domain'}) { next; } + } + if ($tuname) { + if ($tuname ne $env{'user.name'}) { next; } + } + $access=($effect eq 'allow'); + last; + } + } else { + if ($role) { + if ($role ne $urole) { next; } + } + foreach my $scope (split(/\s*\,\s*/,$realm)) { + my ($tdom,$tcrs,$tsec)=split(/\_/,$scope); + if ($tdom) { + if ($tdom ne $udom) { next; } + } + if ($tcrs) { + if ($tcrs ne $ucrs) { next; } + } + if ($tsec) { + if ($tsec ne $usec) { next; } + } + $access=($effect eq 'allow'); + last; + } + if ($realm eq '' && $role eq '') { + $access=($effect eq 'allow'); + } } } return $access; @@ -4334,6 +4654,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 { @@ -4368,7 +4705,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); @@ -4411,8 +4748,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); } @@ -4478,7 +4815,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; } @@ -4517,7 +4854,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); @@ -4625,7 +4962,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)); @@ -4671,10 +5008,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; } @@ -5005,7 +5348,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:.*/) { @@ -5027,8 +5371,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.', '. @@ -5200,9 +5546,15 @@ sub createcourse { } # ----------------------------------------------------------------- Course made # log existence - &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description). - ':'.&escape($inst_code).':'.&escape($course_owner).':'. - &escape($crstype),$uhome); + my $newcourse = { + $udom.'_'.$uname => { + description => &escape($description), + inst_code => &escape($inst_code), + owner => &escape($course_owner), + type => &escape($crstype), + }, + }; + &courseidput($udom,$newcourse); &flushcourselogs(); # set toplevel url my $topurl=$url; @@ -5233,7 +5585,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; } @@ -6172,6 +6524,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); @@ -6545,10 +6903,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 } @@ -6688,12 +7047,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) { @@ -7066,7 +7428,7 @@ sub getCODE { sub rndseed { my ($symb,$courseid,$domain,$username)=@_; my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser(); - if (!$symb) { + if (!defined($symb)) { unless ($symb=$wsymb) { return time; } } if (!$courseid) { $courseid=$wcourseid; } @@ -7572,6 +7934,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; } @@ -7852,8 +8217,10 @@ sub get_dns { } sub reset_hosts_info { + &purge_remembered(); &reset_domain_info(); &reset_hosts_ip_info(); + undef(%name_to_host); undef(%hostname); undef(%hostdom); undef(%libserv); @@ -7945,24 +8312,6 @@ sub get_dns { my %name_to_ip; my %lonid_to_ip; - my %valid_ip; - sub valid_ip { - my ($ip) = @_; - if (exists($iphost{$ip}) || exists($valid_ip{$ip})) { - return 1; - } - my $name = gethostbyip($ip); - my $lonid = &hostname($name); - if (defined($lonid)) { - $valid_ip{$ip} = $lonid; - return 1; - } - my %iphosts = &get_iphost(); - if (ref($iphost{$ip})) { - return 1; - } - } - sub get_hosts_from_ip { my ($ip) = @_; my %iphosts = &get_iphost(); @@ -7994,6 +8343,7 @@ sub get_dns { sub get_iphost { my ($ignore_cache) = @_; + if (!$ignore_cache) { if (%iphost) { return %iphost; @@ -8007,16 +8357,31 @@ sub get_dns { return %iphost; } } + + # get yesterday's info for fallback + my %old_name_to_ip; + my ($ip_info,$cached)= + &Apache::lonnet::is_cached_new('iphost','iphost'); + if ($cached) { + %old_name_to_ip = %{$ip_info->[1]}; + } + my %name_to_host = &all_names(); foreach my $name (keys(%name_to_host)) { my $ip; if (!exists($name_to_ip{$name})) { $ip = gethostbyname($name); if (!$ip || length($ip) ne 4) { - &logthis("Skipping name $name no IP found"); - next; + if (defined($old_name_to_ip{$name})) { + $ip = $old_name_to_ip{$name}; + &logthis("Can't find $name defaulting to old $ip"); + } else { + &logthis("Name $name no IP found"); + next; + } + } else { + $ip=inet_ntoa($ip); } - $ip=inet_ntoa($ip); $name_to_ip{$name} = $ip; } else { $ip = $name_to_ip{$name}; @@ -8028,7 +8393,7 @@ sub get_dns { } &Apache::lonnet::do_cache_new('iphost','iphost', [\%iphost,\%name_to_ip,\%lonid_to_ip], - 24*60*60); + 48*60*60); return %iphost; } @@ -8417,7 +8782,7 @@ explanation of a user role term get_my_roles($uname,$udom,$context,$types,$roles,$roledoms) : 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, +(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