--- loncom/lonnet/perl/lonnet.pm 2006/03/04 01:00:15 1.715
+++ loncom/lonnet/perl/lonnet.pm 2006/04/06 19:14:50 1.726
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.715 2006/03/04 01:00:15 albertel Exp $
+# $Id: lonnet.pm,v 1.726 2006/04/06 19:14:50 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -260,6 +260,13 @@ sub critical {
sub transfer_profile_to_env {
my ($lonidsdir,$handle)=@_;
+ if (!defined($lonidsdir)) {
+ $lonidsdir = $perlvar{'lonIDsDir'};
+ }
+ if (!defined($handle)) {
+ ($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| );
+ }
+
my @profile;
{
open(my $idf,"$lonidsdir/$handle.id");
@@ -272,6 +279,8 @@ sub transfer_profile_to_env {
for ($envi=0;$envi<=$#profile;$envi++) {
chomp($profile[$envi]);
my ($envname,$envvalue)=split(/=/,$profile[$envi],2);
+ $envname=&unescape($envname);
+ $envvalue=&unescape($envvalue);
$env{$envname} = $envvalue;
if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {
if ($time < time-300) {
@@ -324,6 +333,8 @@ sub appenv {
chomp($oldenv[$i]);
if ($oldenv[$i] ne '') {
my ($name,$value)=split(/=/,$oldenv[$i],2);
+ $name=&unescape($name);
+ $value=&unescape($value);
unless (defined($newenv{$name})) {
$newenv{$name}=$value;
}
@@ -336,7 +347,7 @@ sub appenv {
}
my $newname;
foreach $newname (keys %newenv) {
- print $fh "$newname=$newenv{$newname}\n";
+ print $fh &escape($newname).'='.&escape($newenv{$newname})."\n";
}
close($fh);
}
@@ -348,7 +359,6 @@ sub appenv {
sub delenv {
my $delthis=shift;
- my %newenv=();
if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {
&logthis("<font color=\"blue\">WARNING: ".
"Attempt to delete from environment ".$delthis);
@@ -381,8 +391,10 @@ sub delenv {
return 'error: '.$!;
}
foreach my $cur_key (@oldenv) {
- if ($cur_key=~/^$delthis/) {
- my ($key,undef) = split('=',$cur_key,2);
+ my $unescaped_cur_key = &unescape($cur_key);
+ if ($unescaped_cur_key=~/^$delthis/) {
+ my ($key) = split('=',$cur_key,2);
+ $key = &unescape($key);
delete($env{$key});
} else {
print $fh $cur_key;
@@ -843,6 +855,7 @@ sub save_cache {
my ($r)=@_;
if (! $r->is_initial_req()) { return DECLINED; }
&purge_remembered();
+ #&Apache::loncommon::validate_page();
undef(%env);
return OK;
}
@@ -996,13 +1009,13 @@ sub retrievestudentphoto {
# -------------------------------------------------------------------- New chat
sub chatsend {
- my ($newentry,$anon)=@_;
+ my ($newentry,$anon,$group)=@_;
my $cnum=$env{'course.'.$env{'request.course.id'}.'.num'};
my $cdom=$env{'course.'.$env{'request.course.id'}.'.domain'};
my $chome=$env{'course.'.$env{'request.course.id'}.'.home'};
&reply('chatsend:'.$cdom.':'.$cnum.':'.
&escape($env{'user.domain'}.':'.$env{'user.name'}.':'.$anon.':'.
- &escape($newentry)),$chome);
+ &escape($newentry)).':'.$group,$chome);
}
# ------------------------------------------ Find current version of a resource
@@ -1320,7 +1333,7 @@ sub clean_filename {
# --------------- Take an uploaded file and put it into the userfiles directory
# input: $formname - the contents of the file are in $env{"form.$formname"}
-# the desired filenam is in $env{"form.$formname"}
+# the desired filenam is in $env{"form.$formname.filename"}
# $coursedoc - if true up to the current course
# if false
# $subdir - directory in userfile to store the file into
@@ -1331,7 +1344,7 @@ sub clean_filename {
sub userfileupload {
- my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase)=@_;
+ my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname,$destudom)=@_;
if (!defined($subdir)) { $subdir='unknown'; }
my $fname=$env{'form.'.$formname.'.filename'};
$fname=&clean_filename($fname);
@@ -1354,6 +1367,7 @@ sub userfileupload {
close($fh);
return $fullpath.'/'.$fname;
}
+
# Create the directory if not present
$fname="$subdir/$fname";
if ($coursedoc) {
@@ -1369,6 +1383,12 @@ sub userfileupload {
$fname,$formname,$parser,
$allfiles,$codebase);
}
+ } elsif (defined($destuname)) {
+ my $docuname=$destuname;
+ my $docudom=$destudom;
+ return &finishuserfileupload($docuname,$docudom,$formname,
+ $fname,$parser,$allfiles,$codebase);
+
} else {
my $docuname=$env{'user.name'};
my $docudom=$env{'user.domain'};
@@ -2855,6 +2875,13 @@ sub dump {
return %returnhash;
}
+# --------------------------------------------------------- dumpstore interface
+
+sub dumpstore {
+ my ($namespace,$udomain,$uname,$regexp,$range)=@_;
+ return &dump($namespace,$udomain,$uname,$regexp,$range);
+}
+
# -------------------------------------------------------------- keys interface
sub getkeys {
@@ -3005,12 +3032,13 @@ sub putstore {
$items.= &escape($key).'='.&freeze_escape($storehash->{$key}).'&';
}
$items=~s/\&$//;
- $symb=&escape($symb);
- $version=&escape($version);
+ my $esc_symb=&escape($symb);
+ my $esc_v=&escape($version);
my $reply =
- &reply("putstore:$udomain:$uname:$namespace:$symb:$version:$items",
+ &reply("putstore:$udomain:$uname:$namespace:$esc_symb:$esc_v:$items",
$uhome);
if ($reply eq 'unknown_cmd') {
+ # gfall back to way things use to be done
return &old_putstore($namespace,$symb,$version,$storehash,$udomain,
$uname);
}
@@ -3018,7 +3046,30 @@ sub putstore {
}
sub old_putstore {
-
+ my ($namespace,$symb,$version,$storehash,$udomain,$uname)=@_;
+ if (!$udomain) { $udomain=$env{'user.domain'}; }
+ if (!$uname) { $uname=$env{'user.name'}; }
+ my $uhome=&homeserver($uname,$udomain);
+ my %newstorehash;
+ foreach (keys %$storehash) {
+ my $key = $version.':'.&escape($symb).':'.$_;
+ $newstorehash{$key} = $storehash->{$_};
+ }
+ my $items='';
+ my %allitems = ();
+ foreach (keys %newstorehash) {
+ if ($_ =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) {
+ my $key = $1.':keys:'.$2;
+ $allitems{$key} .= $3.':';
+ }
+ $items.=$_.'='.&freeze_escape($newstorehash{$_}).'&';
+ }
+ foreach (keys %allitems) {
+ $allitems{$_} =~ s/\:$//;
+ $items.= $_.'='.$allitems{$_}.'&';
+ }
+ $items=~s/\&$//;
+ return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
}
# ------------------------------------------------------ critical put interface
@@ -4695,6 +4746,12 @@ sub GetFileTimestamp {
sub stat_file {
my ($uri) = @_;
$uri = &clutter($uri);
+
+ # we want just the url part without the unneeded accessor url bits
+ if ($uri =~ m-^/adm/-) {
+ $uri=~s-^/adm/wrapper/-/-;
+ $uri=~s-^/adm/coursedocs/showdoc/-/-;
+ }
my ($udom,$uname,$file,$dir);
if ($uri =~ m-^/(uploaded|editupload)/-) {
($udom,$uname,$file) =
@@ -4715,6 +4772,7 @@ sub stat_file {
my ($result) = &dirlist($file,$udom,$uname,$dir);
my @stats = split('&', $result);
+
if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
shift(@stats); #filename is first
return @stats;
@@ -5061,9 +5119,6 @@ sub EXT {
($env{'user.domain'} eq $udom)) {
$section=$env{'request.course.sec'};
@groups=&sort_course_groups($env{'request.course.groups'},$courseid);
- if (@groups > 0) {
- @groups = sort(@groups);
- }
} else {
if (! defined($usection)) {
$section=&getsection($udom,$uname,$courseid);
@@ -5198,10 +5253,7 @@ sub check_group_parms {
sub sort_course_groups { # Sort groups based on defined rankings. Default is sort().
my ($grouplist,$courseid) = @_;
- my @groups = split/:/,$grouplist;
- if (@groups > 1) {
- @groups = sort(@groups);
- }
+ my @groups = sort(split(/:/,$grouplist));
return @groups;
}
@@ -6405,7 +6457,7 @@ sub clutter {
&& $thisfn!~/\.(sequence|page)$/) {
$thisfn='/adm/coursedocs/showdoc'.$thisfn;
} else {
- &logthis("Got a blank emb style");
+# &logthis("Got a blank emb style");
}
}
}
@@ -7226,6 +7278,27 @@ all args are optional
=item *
+dumpstore($namespace,$udom,$uname,$regexp,$range) :
+dumps the complete (or key matching regexp) namespace into a hash
+($udom, $uname, $regexp, $range are optional) for a namespace that is
+normally &store()ed into
+
+$range should be either an integer '100' (give me the first 100
+ matching records)
+ or be two integers sperated by a - with no spaces
+ '30-50' (give me the 30th through the 50th matching
+ records)
+
+
+=item *
+
+putstore($namespace,$symb,$version,$storehash,$udomain,$uname) :
+replaces a &store() version of data with a replacement set of data
+for a particular resource in a namespace passed in the $storehash hash
+reference
+
+=item *
+
tmpstore($storehash,$symb,$namespace,$udom,$uname) : storage that
works very similar to store/cstore, but all data is stored in a
temporary location and can be reset using tmpreset, $storehash should
@@ -7279,17 +7352,6 @@ put($namespace,$storehash,$udom,$uname)
=item *
-putstore($namespace,$storehash,$udomain,$uname) : stores hash in namesp
-keys used in storehash include version information (e.g., 1:$symb:message etc.) as
-used in records written by &store and retrieved by &restore. This function
-was created for use in editing discussion posts, without incrementing the
-version number included in the key for a particular post. The colon
-separated list of attribute names (e.g., the value associated with the key
-1:keys:$symb) is also generated and passed in the ampersand separated
-items sent to lonnet::reply().
-
-=item *
-
cput($namespace,$storehash,$udom,$uname) : critical put
($udom and $uname are optional)