--- loncom/lonnet/perl/lonnet.pm 2005/03/02 22:26:36 1.602 +++ loncom/lonnet/perl/lonnet.pm 2005/04/05 20:43:27 1.619 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.602 2005/03/02 22:26:36 raeburn Exp $ +# $Id: lonnet.pm,v 1.619 2005/04/05 20:43:27 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -40,7 +40,8 @@ qw(%perlvar %hostname %badServerCache %i %courselogs %accesshash %userrolehash $processmarker $dumpcount %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %domaindescription %domain_auth_def %domain_auth_arg_def - %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit); + %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit + %env); use IO::Socket; use GDBM_File; @@ -54,6 +55,11 @@ use Cache::Memcached; my $readit; my $max_connection_retries = 10; # Or some such value. +require Exporter; + +our @ISA = qw (Exporter); +our @EXPORT = qw(%env); + =pod =head1 Package Variables @@ -279,6 +285,7 @@ sub transfer_profile_to_env { chomp($profile[$envi]); my ($envname,$envvalue)=split(/=/,$profile[$envi]); $ENV{$envname} = $envvalue; + $env{$envname} = $envvalue; if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) { if ($time < time-300) { $Remove{$key}++; @@ -286,6 +293,7 @@ sub transfer_profile_to_env { } } $ENV{'user.environment'} = "$lonidsdir/$handle.id"; + $env{'user.environment'} = "$lonidsdir/$handle.id"; foreach my $expired_key (keys(%Remove)) { &delenv($expired_key); } @@ -303,6 +311,7 @@ sub appenv { delete($newenv{$_}); } else { $ENV{$_}=$newenv{$_}; + $env{$_}=$newenv{$_}; } } @@ -390,6 +399,7 @@ sub delenv { if ($_=~/^$delthis/) { my ($key,undef) = split('=',$_); delete($ENV{$key}); + delete($env{$key}); } else { print $fh $_; } @@ -911,8 +921,8 @@ sub make_room { } sub purge_remembered { - &logthis("Tossing ".scalar(keys(%remembered))); - &logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered)))); + #&logthis("Tossing ".scalar(keys(%remembered))); + #&logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered)))); undef(%remembered); undef(%accessed); } @@ -931,6 +941,19 @@ sub userenvironment { return %returnhash; } +# ---------------------------------------------------------- Get a studentphoto +sub studentphoto { + my ($udom,$unam,$ext) = @_; + my $home=&Apache::lonnet::homeserver($unam,$udom); + my $ret=&Apache::lonnet::reply("studentphoto:$udom:$unam:$ext",$home); + my $url="/uploaded/$udom/$unam/internal/studentphoto.".$ext; + if ($ret ne 'ok') { + return '/adm/lonKaputt/lonlogo_broken.gif'; + } + my $tokenurl=&Apache::lonnet::tokenwrapper($url); + return $tokenurl; +} + # -------------------------------------------------------------------- New chat sub chatsend { @@ -994,27 +1017,27 @@ sub subscribe { sub repcopy { my $filename=shift; $filename=~s/\/+/\//g; - if ($filename=~m|^/home/httpd/html/adm/|) { return 'OK'; } - if ($filename=~m|^/home/httpd/html/lonUsers/|) { return 'OK'; } + if ($filename=~m|^/home/httpd/html/adm/|) { return 'ok'; } + if ($filename=~m|^/home/httpd/html/lonUsers/|) { return 'ok'; } if ($filename=~m|^/home/httpd/html/userfiles/| or - $filename=~m|^/*uploaded/|) { + $filename=~m -^/*(uploaded|editupload)/-) { return &repcopy_userfile($filename); } $filename=~s/[\n\r]//g; my $transname="$filename.in.transfer"; - if ((-e $filename) || (-e $transname)) { return 'OK'; } + if ((-e $filename) || (-e $transname)) { return 'ok'; } my $remoteurl=subscribe($filename); if ($remoteurl =~ /^con_lost by/) { &logthis("Subscribe returned $remoteurl: $filename"); - return 'HTTP_SERVICE_UNAVAILABLE'; + return 'unavailable'; } elsif ($remoteurl eq 'not_found') { #&logthis("Subscribe returned not_found: $filename"); - return 'HTTP_NOT_FOUND'; + return 'not_found'; } elsif ($remoteurl =~ /^rejected by/) { &logthis("Subscribe returned $remoteurl: $filename"); - return 'FORBIDDEN'; + return 'forbidden'; } elsif ($remoteurl eq 'directory') { - return 'OK'; + return 'ok'; } else { my $author=$filename; $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; @@ -1025,7 +1048,7 @@ sub repcopy { my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]"; if ($path ne "$perlvar{'lonDocRoot'}/res") { &logthis("Malconfiguration for replication: $filename"); - return 'HTTP_BAD_REQUEST'; + return 'bad_request'; } my $count; for ($count=5;$count<$#parts;$count++) { @@ -1042,7 +1065,7 @@ sub repcopy { my $message=$response->status_line; &logthis("WARNING:" ." LWP get: $message: $filename"); - return 'HTTP_SERVICE_UNAVAILABLE'; + return 'unavailable'; } else { if ($remoteurl!~/\.meta$/) { my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta'); @@ -1054,7 +1077,7 @@ sub repcopy { } } rename($transname,$filename); - return 'OK'; + return 'ok'; } } } @@ -1063,6 +1086,9 @@ sub repcopy { # ------------------------------------------------ Get server side include body sub ssi_body { my ($filelink,%form)=@_; + if (! exists($form{'LONCAPA_INTERNAL_no_discussion'})) { + $form{'LONCAPA_INTERNAL_no_discussion'}='true'; + } my $output=($filelink=~/^http\:/?&externalssi($filelink): &ssi($filelink,%form)); $output=~s|//(\s*)?\s||gs; @@ -1196,10 +1222,6 @@ sub process_coursefile { return $fetchresult; } -# --------------- Take an uploaded file and put it into the userfiles directory -# input: name of form element, coursedoc=1 means this is for the course -# output: url of file in userspace - sub clean_filename { my ($fname)=@_; # Replace Windows backslashes by forward slashes @@ -1216,6 +1238,11 @@ sub clean_filename { return $fname; } +# --------------- Take an uploaded file and put it into the userfiles directory +# input: name of form element, coursedoc=1 means this is for the course +# output: url of file in userspace + + sub userfileupload { my ($formname,$coursedoc,$subdir)=@_; if (!defined($subdir)) { $subdir='unknown'; } @@ -1289,7 +1316,6 @@ sub finishuserfileupload { } # Notify homeserver to grep it # - &Apache::lonnet::logthis("fetching ".$path.$file); my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome); if ($fetchresult eq 'ok') { # @@ -1305,7 +1331,7 @@ sub finishuserfileupload { sub removeuploadedurl { my ($url)=@_; my (undef,undef,$udom,$uname,$fname)=split('/',$url,5); - return &Apache::lonnet::removeuserfile($uname,$udom,$fname); + return &removeuserfile($uname,$udom,$fname); } sub removeuserfile { @@ -2703,7 +2729,7 @@ sub allowed { # Free bre access to user's own portfolio contents my ($space,$domain,$name,$dir)=split('/',$uri); - if (('uploaded' eq $space) && ($ENV{'user.name'} eq $name) && + if (($space=~/^(uploaded|ediupload)$/) && ($ENV{'user.name'} eq $name) && ($ENV{'user.domain'} eq $domain) && ('portfolio' eq $dir)) { return 'F'; } @@ -2772,7 +2798,7 @@ sub allowed { } # URI is an uploaded document for this course - +# not allowing 'edit' access (editupload) to uploaded course docs if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) { my $refuri=$ENV{'httpref.'.$orguri}; if ($refuri) { @@ -3712,8 +3738,11 @@ sub is_locked { my @check; my $is_locked; push @check, $file_name; - my %locked = &Apache::lonnet::get('file_permissions',\@check, - $ENV{'user.domain'},$ENV{'user.name'}); + my %locked = &get('file_permissions',\@check, + $ENV{'user.domain'},$ENV{'user.name'}); + my ($tmp)=keys(%locked); + if ($tmp=~/^error:/) { undef(%locked); } + if (ref($locked{$file_name}) eq 'ARRAY') { $is_locked = 'true'; } else { @@ -3725,11 +3754,14 @@ sub is_locked { sub mark_as_readonly { my ($domain,$user,$files,$what) = @_; - my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user); + my %current_permissions = &dump('file_permissions',$domain,$user); + my ($tmp)=keys(%current_permissions); + if ($tmp=~/^error:/) { undef(%current_permissions); } + foreach my $file (@{$files}) { push(@{$current_permissions{$file}},$what); } - &Apache::lonnet::put('file_permissions',\%current_permissions,$domain,$user); + &put('file_permissions',\%current_permissions,$domain,$user); return; } @@ -3806,7 +3838,10 @@ sub files_not_in_path { sub get_marked_as_readonly { my ($domain,$user,$what) = @_; - my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user); + my %current_permissions = &dump('file_permissions',$domain,$user); + my ($tmp)=keys(%current_permissions); + if ($tmp=~/^error:/) { undef(%current_permissions); } + my @readonly_files; while (my ($file_name,$value) = each(%current_permissions)) { if (ref($value) eq "ARRAY"){ @@ -3825,7 +3860,10 @@ sub get_marked_as_readonly { sub get_marked_as_readonly_hash { my ($domain,$user,$what) = @_; - my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user); + my %current_permissions = &dump('file_permissions',$domain,$user); + my ($tmp)=keys(%current_permissions); + if ($tmp=~/^error:/) { undef(%current_permissions); } + my %readonly_files; while (my ($file_name,$value) = each(%current_permissions)) { if (ref($value) eq "ARRAY"){ @@ -3846,8 +3884,11 @@ sub unmark_as_readonly { # unmarks all files locked by $what # for portfolio submissions, $what contains $crsid and $symb my ($domain,$user,$what) = @_; - my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user); - my @readonly_files = &Apache::lonnet::get_marked_as_readonly($domain,$user,$what); + my %current_permissions = &dump('file_permissions',$domain,$user); + my ($tmp)=keys(%current_permissions); + if ($tmp=~/^error:/) { undef(%current_permissions); } + + my @readonly_files = &get_marked_as_readonly($domain,$user,$what); foreach my $file(@readonly_files){ my $current_locks = $current_permissions{$file}; my @new_locks; @@ -3862,12 +3903,12 @@ sub unmark_as_readonly { $current_permissions{$file} = \@new_locks; } else { push(@del_keys, $file); - &Apache::lonnet::del('file_permissions',\@del_keys, $domain, $user); + &del('file_permissions',\@del_keys, $domain, $user); delete $current_permissions{$file}; } } } - &Apache::lonnet::put('file_permissions',\%current_permissions,$domain,$user); + &put('file_permissions',\%current_permissions,$domain,$user); return; } @@ -3895,19 +3936,37 @@ sub dirlist { if($udom) { if($uname) { - my $listing=reply('ls:'.$dirRoot.'/'.$uri, + my $listing=reply('ls2:'.$dirRoot.'/'.$uri, homeserver($uname,$udom)); - return split(/:/,$listing); + my @listing_results; + if ($listing eq 'unknown_cmd') { + $listing=reply('ls:'.$dirRoot.'/'.$uri, + homeserver($uname,$udom)); + @listing_results = split(/:/,$listing); + } else { + @listing_results = map { &unescape($_); } split(/:/,$listing); + } + return @listing_results; } elsif(!defined($alternateDirectoryRoot)) { my $tryserver; my %allusers=(); foreach $tryserver (keys %libserv) { if($hostdom{$tryserver} eq $udom) { - my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'. + my $listing=reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'. $udom, $tryserver); - if (($listing ne 'no_such_dir') && ($listing ne 'empty') - && ($listing ne 'con_lost')) { - foreach (split(/:/,$listing)) { + my @listing_results; + if ($listing eq 'unknown_cmd') { + $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'. + $udom, $tryserver); + @listing_results = split(/:/,$listing); + } else { + @listing_results = + map { &unescape($_); } split(/:/,$listing); + } + if ($listing_results[0] ne 'no_such_dir' && + $listing_results[0] ne 'empty' && + $listing_results[0] ne 'con_lost') { + foreach (@listing_results) { my ($entry,@stat)=split(/&/,$_); $allusers{$entry}=1; } @@ -4124,7 +4183,8 @@ sub EXT { if ($realm eq 'user') { # --------------------------------------------------------------- user.resource if ($space eq 'resource') { - if (defined($Apache::lonhomework::parsing_a_problem)) { + if (defined($Apache::lonhomework::parsing_a_problem) || + defined($Apache::lonhomework::parsing_a_task)) { return $Apache::lonhomework::history{$qualifierrest}; } else { my %restored; @@ -4424,7 +4484,7 @@ sub metadata { my %metathesekeys=(); unless ($filename=~/\.meta$/) { $filename.='.meta'; } my $metastring; - if ($uri !~ m|^uploaded/|) { + if ($uri !~ m -^(uploaded|editupload)/-) { my $file=&filelocation('',&clutter($filename)); #push(@{$metaentry{$uri.'.file'}},$file); $metastring=&getfile($file); @@ -4448,7 +4508,7 @@ sub metadata { } else { $metaentry{':packages'}=$package.$keyroot; } - foreach (keys %packagetab) { + foreach (sort keys %packagetab) { my $part=$keyroot; $part=~s/^\_//; if ($_=~/^\Q$package\E\&/ || @@ -4665,7 +4725,23 @@ sub gettitle { if (!$title) { $title=(split('/',$urlsymb))[-1]; } return $title; } - + +sub get_slot { + my ($which,$cnum,$cdom)=@_; + if (!$cnum || !$cdom) { + (undef,my $courseid)=&Apache::lonxml::whichuser(); + $cdom=$ENV{'course.'.$courseid.'.domain'}; + $cnum=$ENV{'course.'.$courseid.'.num'}; + } + my %slotinfo=&get('slots',[$which],$cdom,$cnum); + &Apache::lonhomework::showhash(%slotinfo); + my ($tmp)=keys(%slotinfo); + if ($tmp=~/^error:/) { return (); } + if (ref($slotinfo{$which}) eq 'HASH') { + return %{$slotinfo{$which}}; + } + return $slotinfo{$which}; +} # ------------------------------------------------- Update symbolic store links sub symblist { @@ -4767,7 +4843,7 @@ sub decode_symb { sub fixversion { my $fn=shift; - if ($fn=~/^(adm|uploaded|public)/) { return $fn; } + if ($fn=~/^(adm|uploaded|editupload|public)/) { return $fn; } my %bighash; my $uri=&clutter($fn); my $key=$ENV{'request.course.id'}.'_'.$uri; @@ -4821,7 +4897,7 @@ sub symbread { my $syval=''; if (($ENV{'request.course.fn'}) && ($thisfn)) { my $targetfn = $thisfn; - if ( ($thisfn =~ m/^uploaded\//) && ($thisfn !~ m/\.(page|sequence)$/) ) { + if ( ($thisfn =~ m/^(uploaded|editupload)\//) && ($thisfn !~ m/\.(page|sequence)$/) ) { $targetfn = 'adm/wrapper/'.$thisfn; } if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db', @@ -4958,8 +5034,9 @@ sub validCODE { sub getCODE { if (&validCODE($ENV{'form.CODE'})) { return $ENV{'form.CODE'}; } - if (defined($Apache::lonhomework::parsing_a_problem) && - &validCODE($Apache::lonhomework::history{'resource.CODE'})) { + if ( (defined($Apache::lonhomework::parsing_a_problem) || + defined($Apache::lonhomework::parsing_a_task) ) && + &validCODE($Apache::lonhomework::history{'resource.CODE'})) { return $Apache::lonhomework::history{'resource.CODE'}; } return undef; @@ -5229,16 +5306,15 @@ sub receipt { sub getfile { my ($file) = @_; - - if ($file =~ m|^/*uploaded/|) { $file=&filelocation("",$file); } + if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); } &repcopy($file); return &readfile($file); } sub repcopy_userfile { my ($file)=@_; - if ($file =~ m|^/*uploaded/|) { $file=&filelocation("",$file); } - if ($file =~ m|^/home/httpd/html/lonUsers/|) { return 'OK'; } + if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); } + if ($file =~ m|^/home/httpd/html/lonUsers/|) { return 'ok'; } my ($cdom,$cnum,$filename) = ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+([^/]+)/+([^/]+)/+(.*)|); my ($info,$rtncode); @@ -5261,7 +5337,7 @@ sub repcopy_userfile { return -1; } if ($info < $fileinfo[9]) { - return 'OK'; + return 'ok'; } $info = ''; $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode); @@ -5295,7 +5371,7 @@ sub repcopy_userfile { open(FILE,">$file"); print FILE $info; close(FILE); - return 'OK'; + return 'ok'; } sub tokenwrapper { @@ -5352,9 +5428,9 @@ sub filelocation { if ($file=~m:^/~:) { # is a contruction space reference $location = $file; $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; - } elsif ($file=~/^\/*uploaded/) { # is an uploaded file + } elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file my ($udom,$uname,$filename)= - ($file=~m|^/+uploaded/+([^/]+)/+([^/]+)/+(.*)$|); + ($file=~m -^/+(?:uploaded|editupload)/+([^/]+)/+([^/]+)/+(.*)$-); my $home=&homeserver($uname,$udom); my $is_me=0; my @ids=¤t_machine_ids(); @@ -5366,9 +5442,6 @@ sub filelocation { $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'. $udom.'/'.$uname.'/'.$filename; } - } elsif ($file =~ /^\/adm\/portfolio\//) { - $file =~ s:^/adm/portfolio/::; - $location = $location=&Apache::loncommon::propath($ENV{'user.domain'},$ENV{'user.name'}).'/userfiles/portfolio/'.$file; } else { $file=~s/^\Q$perlvar{'lonDocRoot'}\E//; $file=~s:^/res/:/:; @@ -5439,7 +5512,7 @@ sub declutter { sub clutter { my $thisfn='/'.&declutter(shift); - unless ($thisfn=~/^\/(uploaded|adm|userfiles|ext|raw|priv|public)\//) { + unless ($thisfn=~/^\/(uploaded|editupload|adm|userfiles|ext|raw|priv|public)\//) { $thisfn='/res'.$thisfn; } return $thisfn; @@ -5590,6 +5663,8 @@ BEGIN { } } close($config); + # FIXME: dev server don't want this, production servers _do_ want this + #&get_iphost(); } sub get_iphost { @@ -6115,8 +6190,8 @@ subscribe($fname) : subscribe to a resou repcopy($filename) : subscribes to the requested file, and attempts to replicate from the owning library server, Might return -'HTTP_SERVICE_UNAVAILABLE', 'HTTP_NOT_FOUND', 'FORBIDDEN', 'OK', or -'HTTP_BAD_REQUEST', also attempts to grab the metadata for the +'unavailable', 'not_found', 'forbidden', 'ok', or +'bad_request', also attempts to grab the metadata for the resource. Expects the local filesystem pathname (/home/httpd/html/res/....) @@ -6458,6 +6533,91 @@ declutter() : declutters URLs (remove do =back +=head2 Usererfile file routines (/uploaded*) + +=over 4 + +=item * + +userfileupload(): main rotine for putting a file in a user or course's + filespace, arguments are, + + formname - required - this is the name of the element in $ENV where the + filename, and the contents of the file to create/modifed exist + the filename is in $ENV{'form.'.$formname.'.filename'} and the + contents of the file is located in $ENV{'form.'.$formname} + coursedoc - if true, store the file in the course of the active role + of the current user + subdir - required - subdirectory to put the file in under ../userfiles/ + if undefined, it will be placed in "unknown" + + (This routine calls clean_filename() to remove any dangerous + characters from the filename, and then calls finuserfileupload() to + complete the transaction) + + returns either the url of the uploaded file (/uploaded/....) if successful + and /adm/notfound.html if unsuccessful + +=item * + +clean_filename(): routine for cleaing a filename up for storage in + userfile space, argument is: + + filename - proposed filename + +returns: the new clean filename + +=item * + +finishuserfileupload(): routine that creaes and sends the file to +userspace, probably shouldn't be called directly + + docuname: username or courseid of destination for the file + docudom: domain of user/course of destination for the file + docuhome: loncapa id of the library server that is getting the file + formname: same as for userfileupload() + fname: filename (inculding subdirectories) for the file + + returns either the url of the uploaded file (/uploaded/....) if successful + and /adm/notfound.html if unsuccessful + +=item * + +renameuserfile(): renames an existing userfile to a new name + + Args: + docuname: username or courseid of destination for the file + docudom: domain of user/course of destination for the file + old: current file name (including any subdirs under userfiles) + new: desired file name (including any subdirs under userfiles) + +=item * + +mkdiruserfile(): creates a directory is a userfiles dir + + Args: + docuname: username or courseid of destination for the file + docudom: domain of user/course of destination for the file + dir: dir to create (including any subdirs under userfiles) + +=item * + +removeuserfile(): removes a file that exists in userfiles + + Args: + docuname: username or courseid of destination for the file + docudom: domain of user/course of destination for the file + fname: filname to delete (including any subdirs under userfiles) + +=item * + +removeuploadedurl(): convience function for removeuserfile() + + Args: + url: a full /uploaded/... url to delete + +=back + =head2 HTTP Helper Routines =over 4