--- loncom/lonnet/perl/lonnet.pm 2006/03/04 06:03:30 1.717
+++ loncom/lonnet/perl/lonnet.pm 2006/04/18 18:11:16 1.729
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.717 2006/03/04 06:03:30 albertel Exp $
+# $Id: lonnet.pm,v 1.729 2006/04/18 18:11:16 www Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -45,7 +45,6 @@ qw(%perlvar %hostname %badServerCache %i
use IO::Socket;
use GDBM_File;
-use Apache::Constants qw(:common :http);
use HTML::LCParser;
use HTML::Parser;
use Fcntl qw(:flock);
@@ -86,6 +85,28 @@ delayed.
# --------------------------------------------------------------------- Logging
+{
+ my $logid;
+ sub instructor_log {
+ my ($hash_name,$storehash,$delflag,$uname,$udom)=@_;
+ $logid++;
+ my $id=time().'00000'.$$.'00000'.$logid;
+ return &Apache::lonnet::put('nohist_'.$hash_name,
+ {
+ $id.'_exe_uname' => $env{'user.name'},
+ $id.'_exe_udom' => $env{'user.domain'},
+ $id.'_exe_time' => time(),
+ $id.'_exe_ip' => $ENV{'REMOTE_ADDR'},
+ $id.'_delflag' => $delflag,
+ $id.'_logentry' => $storehash,
+ $id.'_uname' => $uname,
+ $id.'_udom' => $udom,
+ },
+ $env{'course.'.$env{'request.course.id'}.'.domain'},
+ $env{'course.'.$env{'request.course.id'}.'.num'}
+ );
+ }
+}
sub logtouch {
my $execdir=$perlvar{'lonDaemons'};
@@ -260,6 +281,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 +300,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 +354,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 +368,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 +380,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 +412,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;
@@ -840,11 +873,9 @@ sub getsection {
}
sub save_cache {
- my ($r)=@_;
- if (! $r->is_initial_req()) { return DECLINED; }
&purge_remembered();
+ #&Apache::loncommon::validate_page();
undef(%env);
- return OK;
}
my $to_remember=-1;
@@ -996,13 +1027,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 +1351,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 +1362,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 +1385,7 @@ sub userfileupload {
close($fh);
return $fullpath.'/'.$fname;
}
+
# Create the directory if not present
$fname="$subdir/$fname";
if ($coursedoc) {
@@ -1369,6 +1401,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'};
@@ -3972,7 +4010,7 @@ sub get_users_groups {
my $grouplist;
foreach my $key (keys %roleshash) {
if ($key =~ /^\Q$courseid\E\/(\w+)\_gr$/) {
- unless ($roleshash{$key} =~ /_1_1$/) { # deleted membership
+ unless ($roleshash{$key} =~ /_\d+_\-1$/) { # deleted membership
$grouplist .= $1.':';
}
}
@@ -4726,6 +4764,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) =
@@ -4746,6 +4790,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;
@@ -5092,9 +5137,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);
@@ -5229,10 +5271,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;
}
@@ -6436,7 +6475,7 @@ sub clutter {
&& $thisfn!~/\.(sequence|page)$/) {
$thisfn='/adm/coursedocs/showdoc'.$thisfn;
} else {
- &logthis("Got a blank emb style");
+# &logthis("Got a blank emb style");
}
}
}
@@ -6504,7 +6543,6 @@ sub goodbye {
&logthis(sprintf("%-20s is %s",'hits',$hits));
&flushcourselogs();
&logthis("Shutting down");
- return DONE;
}
BEGIN {