--- loncom/lonnet/perl/lonnet.pm 2007/07/26 04:05:43 1.900
+++ loncom/lonnet/perl/lonnet.pm 2007/09/25 00:21:12 1.913
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.900 2007/07/26 04:05:43 albertel Exp $
+# $Id: lonnet.pm,v 1.913 2007/09/25 00:21:12 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -861,21 +861,39 @@ sub inst_directory_query {
my $udom = $srch->{'srchdomain'};
my %results;
my $homeserver = &domain($udom,'primary');
+ my $outcome;
if ($homeserver ne '') {
- my $response=&reply("instdirsrch:$udom".':'.
- &escape($srch->{'srchby'}).':'.
- &escape($srch->{'srchterm'}).':'.
- $srch->{'srchtype'},$homeserver);
- if ($response ne 'refused') {
- my @matches = split/&/,$response;
- foreach my $match (@matches) {
- my ($key,$value) = split(/=/,$match);
- my %userhash = &str2hash(&unescape($value));
- $results{&unescape($key).':'.$udom} = \%userhash;
+ 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 %results;
+ return ($outcome,%results);
}
sub usersearch {
@@ -888,13 +906,13 @@ sub usersearch {
if (&host_domain($tryserver) eq $dom) {
my $host=&hostname($tryserver);
my $queryid=
- &reply("querysend:".&escape($query).':'.&escape($dom).':'.
- &escape($srch->{'srchby'}).'%%'.
+ &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);
- return 'error: '.$queryid;
+ next;
}
my $reply = &get_query_reply($queryid);
my $maxtries = 1;
@@ -906,20 +924,23 @@ sub usersearch {
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 = split(/&/,$reply);
+ my @matches;
+ if ($reply =~ /\n/) {
+ @matches = split(/\n/,$reply);
+ } else {
+ @matches = split(/\&/,$reply);
+ }
foreach my $match (@matches) {
- my @items = split(/:/,$match);
my ($uname,$udom,%userhash);
- foreach my $entry (@items) {
- my ($key,$value) = split(/=/,$entry);
- $key = &unescape($key);
- $value = &unescape($value);
+ 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;
}
@@ -929,6 +950,100 @@ sub usersearch {
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 {
@@ -1205,8 +1320,10 @@ 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);
@@ -2081,7 +2198,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});
@@ -2203,7 +2320,6 @@ sub userrolelog {
{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
= $tend.':'.$tstart;
}
- &flushcourselogs();
}
sub get_course_adv_roles {
@@ -4499,7 +4615,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);
@@ -4542,8 +4658,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);
}
@@ -4609,7 +4725,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;
}
@@ -4648,7 +4764,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);
@@ -4756,7 +4872,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));
@@ -6306,6 +6422,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);
@@ -6679,10 +6801,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
}
@@ -6822,12 +6945,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) {
@@ -7706,6 +7832,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;
}
@@ -8551,7 +8680,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