--- loncom/lonnet/perl/lonnet.pm 2007/07/26 15:43:35 1.901
+++ loncom/lonnet/perl/lonnet.pm 2007/10/06 04:32:40 1.921
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.901 2007/07/26 15:43:35 albertel Exp $
+# $Id: lonnet.pm,v 1.921 2007/10/06 04:32:40 raeburn 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);
}
@@ -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 {
@@ -861,21 +918,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 +963,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 +981,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 +1007,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,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; }
@@ -1996,7 +2172,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') {
@@ -2009,23 +2185,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' => &escape($coursedescrbuf{$crsid}),
+ 'inst_code' => &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,'timeonly');
}
#
# File accesses
@@ -2203,7 +2377,6 @@ sub userrolelog {
{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
= $tend.':'.$tstart;
}
- &flushcourselogs();
}
sub get_course_adv_roles {
@@ -2332,31 +2505,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->{$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]);
+ }
+ }
}
}
}
@@ -4542,8 +4761,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);
}
@@ -4802,10 +5021,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;
}
@@ -5334,10 +5559,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) {
@@ -5367,7 +5597,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;
}
@@ -6306,6 +6536,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 +6915,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 +7059,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 +7946,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 +8794,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