--- loncom/lonnet/perl/lonnet.pm	2004/06/21 22:01:39	1.513
+++ loncom/lonnet/perl/lonnet.pm	2004/08/27 18:37:03	1.533
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.513 2004/06/21 22:01:39 banghart Exp $
+# $Id: lonnet.pm,v 1.533 2004/08/27 18:37:03 banghart Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -38,7 +38,7 @@ use vars
 qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom 
    %libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache
    %courselogs %accesshash %userrolehash $processmarker $dumpcount 
-   %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache 
+   %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseresdatacache 
    %userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def 
    %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir);
 
@@ -1047,6 +1047,7 @@ sub currentversion {
 sub subscribe {
     my $fname=shift;
     if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return ''; }
+    $fname=~s/[\n\r]//g;
     my $author=$fname;
     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
     my ($udom,$uname)=split(/\//,$author);
@@ -1067,6 +1068,7 @@ sub repcopy {
     my $filename=shift;
     $filename=~s/\/+/\//g;
     if ($filename=~/^\/home\/httpd\/html\/adm\//) { return OK; }
+    $filename=~s/[\n\r]//g;
     my $transname="$filename.in.transfer";
     if ((-e $filename) || (-e $transname)) { return OK; }
     my $remoteurl=subscribe($filename);
@@ -1131,10 +1133,10 @@ sub ssi_body {
     my ($filelink,%form)=@_;
     my $output=($filelink=~/^http\:/?&externalssi($filelink):
                                      &ssi($filelink,%form));
-    $output=~s/^.*?\<body[^\>]*\>//si;
-    $output=~s/(.*)\<\/body\s*\>.*?$/$1/si;
     $output=~
             s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs;
+    $output=~s/^.*?\<body[^\>]*\>//si;
+    $output=~s/(.*)\<\/body\s*\>.*?$/$1/si;
     return $output;
 }
 
@@ -1267,10 +1269,8 @@ sub process_coursefile {
 # 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'; }
-    my $fname=$ENV{'form.'.$formname.'.filename'};
+sub clean_filename {
+    my ($fname)=@_;
 # Replace Windows backslashes by forward slashes
     $fname=~s/\\/\//g;
 # Get rid of everything but the actual filename
@@ -1279,9 +1279,33 @@ sub userfileupload {
     $fname=~s/\s+/\_/g;
 # Replace all other weird characters by nothing
     $fname=~s/[^\w\.\-]//g;
+    return $fname;
+}
+
+sub userfileupload {
+    my ($formname,$coursedoc,$subdir)=@_;
+    if (!defined($subdir)) { $subdir='unknown'; }
+    my $fname=$ENV{'form.'.$formname.'.filename'};
+    $fname=&clean_filename($fname);
 # See if there is anything left
     unless ($fname) { return 'error: no uploaded file'; }
     chop($ENV{'form.'.$formname});
+    if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) { #files uploaded to help request form are handled differently
+        my $now = time;
+        my $filepath = 'tmp/helprequests/'.$now;
+        my @parts=split(/\//,$filepath);
+        my $fullpath = $perlvar{'lonDaemons'};
+        for (my $i=0;$i<@parts;$i++) {
+            $fullpath .= '/'.$parts[$i];
+            if ((-e $fullpath)!=1) {
+                mkdir($fullpath,0777);
+            }
+        }
+        open(my $fh,'>'.$fullpath.'/'.$fname);
+        print $fh $ENV{'form.'.$formname};
+        close($fh);
+        return $fullpath.'/'.$fname; 
+    }
 # Create the directory if not present
     my $docuname='';
     my $docudom='';
@@ -1356,6 +1380,19 @@ sub removeuserfile {
     return &reply("removeuserfile:$docudom/$docuname/$fname",$home);
 }
 
+sub mkdiruserfile {
+    my ($docuname,$docudom,$dir)=@_;
+    my $home=&homeserver($docuname,$docudom);
+    return &reply("mkdiruserfile:".&escape("$docudom/$docuname/$dir"),$home);
+}
+
+sub renameuserfile {
+    my ($docuname,$docudom,$old,$new)=@_;
+    my $home=&homeserver($docuname,$docudom);
+    return &reply("renameuserfile:$docudom:$docuname:".&escape("$old").':'.
+		  &escape("$new"),$home);
+}
+
 # ------------------------------------------------------------------------- Log
 
 sub log {
@@ -1395,10 +1432,12 @@ sub flushcourselogs {
         }
         if ($courseidbuffer{$coursehombuf{$crsid}}) {
            $courseidbuffer{$coursehombuf{$crsid}}.='&'.
-			 &escape($crsid).'='.&escape($coursedescrbuf{$crsid});
+			 &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
+                         '='.&escape($courseinstcodebuf{$crsid});
         } else {
            $courseidbuffer{$coursehombuf{$crsid}}=
-			 &escape($crsid).'='.&escape($coursedescrbuf{$crsid});
+			 &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
+                         '='.&escape($courseinstcodebuf{$crsid});
         }    
     }
 #
@@ -1472,6 +1511,8 @@ sub courselog {
        $ENV{'course.'.$ENV{'request.course.id'}.'.home'};
     $coursedescrbuf{$ENV{'request.course.id'}}=
        $ENV{'course.'.$ENV{'request.course.id'}.'.description'};
+    $courseinstcodebuf{$ENV{'request.course.id'}}=
+       $ENV{'course.'.$ENV{'request.course.id'}.'.internal.coursecode'};
     if (defined $courselogs{$ENV{'request.course.id'}}) {
 	$courselogs{$ENV{'request.course.id'}}.='&'.$what;
     } else {
@@ -1596,7 +1637,7 @@ sub getannounce {
 	if ($announcement=~/\w/) { 
 	    return 
    '<table bgcolor="#FF5555" cellpadding="5" cellspacing="3">'.
-   '<tr><td bgcolor="#FFFFFF"><pre>'.$announcement.'</pre></td></tr></table>'; 
+   '<tr><td bgcolor="#FFFFFF"><tt>'.$announcement.'</tt></td></tr></table>'; 
 	} else {
 	    return '';
 	}
@@ -1627,7 +1668,7 @@ sub courseiddump {
                                $tryserver))) {
 		    my ($key,$value)=split(/\=/,$_);
                     if (($key) && ($value)) {
-		        $returnhash{&unescape($key)}=&unescape($value);
+		        $returnhash{&unescape($key)}=$value;
                     }
                 }
             }
@@ -2571,6 +2612,30 @@ sub put {
    return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
 }
 
+# ---------------------------------------------------------- putstore interface
+                                                                                     
+sub putstore {
+   my ($namespace,$storehash,$udomain,$uname)=@_;
+   if (!$udomain) { $udomain=$ENV{'user.domain'}; }
+   if (!$uname) { $uname=$ENV{'user.name'}; }
+   my $uhome=&homeserver($uname,$udomain);
+   my $items='';
+   my %allitems = ();
+   foreach (keys %$storehash) {
+       if ($_ =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) {
+           my $key = $1.':keys:'.$2;
+           $allitems{$key} .= $3.':';
+       }
+       $items.=$_.'='.&escape($$storehash{$_}).'&';
+   }
+   foreach (keys %allitems) {
+       $allitems{$_} =~ s/\:$//;
+       $items.= $_.'='.$allitems{$_}.'&';
+   }
+   $items=~s/\&$//;
+   return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
+}
+
 # ------------------------------------------------------ critical put interface
 
 sub cput {
@@ -2653,8 +2718,8 @@ sub allowed {
 
     if (defined($ENV{'allowed.'.$priv})) { return $ENV{'allowed.'.$priv}; }
 # Free bre access to adm and meta resources
-
-    if ((($uri=~/^adm\//) || ($uri=~/\.meta$/)) && ($priv eq 'bre')) {
+    if (((($uri=~/^adm\//) && ($uri !~ m|/bulletinboard$|)) 
+	 || ($uri=~/\.meta$/)) && ($priv eq 'bre')) {
 	return 'F';
     }
 
@@ -3073,11 +3138,21 @@ sub fetch_enrollment_query {
     $cmd = &escape($cmd);
     my $query = 'fetchenrollment';
     my $queryid=&reply("querysend:".$query.':'.$dom.':'.$ENV{'user.name'}.':'.$cmd,$homeserver);
-    unless ($queryid=~/^\Q$host\E\_/) { return 'error: '.$queryid; }
+    unless ($queryid=~/^\Q$host\E\_/) { 
+        &logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum); 
+        return 'error: '.$queryid;
+    }
     my $reply = &get_query_reply($queryid);
-    unless ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
-        unless ($homeserver eq $perlvar{'lonHostID'}) {
-            my @responses = split/:/,$reply;
+    if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
+        &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$ENV{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum);
+    } else {
+        my @responses = split/:/,$reply;
+        if ($homeserver eq $perlvar{'lonHostID'}) {
+            foreach (@responses) {
+                my ($key,$value) = split/=/,$_;
+                $$replyref{$key} = $value;
+            }
+        } else {
             my $pathname = $perlvar{'lonDaemons'}.'/tmp';
             foreach (@responses) {
                 my ($key,$value) = split/=/,$_;
@@ -3087,10 +3162,14 @@ sub fetch_enrollment_query {
                         my $filename = $dom.'_'.$key.'_'.$_.'_classlist.xml';
                         my $destname = $pathname.'/'.$filename;
                         my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver);
-                        unless ($xml_classlist =~ /^error/) {
+                        if ($xml_classlist =~ /^error/) {
+                            &logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum);
+                        } else {
                             if ( open(FILE,">$destname") ) {
                                 print FILE &unescape($xml_classlist);
                                 close(FILE);
+                            } else {
+                                &logthis('fetch_enrollment_query - error opening classlist file '.$destname.' '.$context.' '.$cnum);
                             }
                         }
                     }
@@ -3169,7 +3248,7 @@ sub auto_get_sections {
 sub auto_new_course {
     my ($cnum,$cdom,$inst_course_id,$owner) = @_;
     my $homeserver = &homeserver($cnum,$cdom);
-    my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner,':'.$cdom,$homeserver));
+    my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner.':'.$cdom,$homeserver));
     return $response;
 }
                                                                                    
@@ -3194,6 +3273,32 @@ sub auto_create_password {
     return ($authparam,$create_passwd,$authchk);
 }
 
+sub auto_instcode_format {
+    my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,$cat_order) = @_;
+    my $courses = '';
+    my $homeserver;
+    if ($caller eq 'global') {
+        $homeserver = $perlvar{'lonHostID'};
+    } else {
+        $homeserver = &homeserver($caller,$codedom);
+    }
+    my $host=$hostname{$homeserver};
+    foreach (keys %{$instcodes}) {
+        $courses .= &escape($_).'='.&escape($$instcodes{$_}).'&';
+    }
+    chop($courses);
+    my $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$homeserver);
+    unless ($response =~ /(con_lost|error|no_such_host|refused)/) {
+        my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = split/:/,$response;
+        %{$codes} = &str2hash($codes_str);
+        @{$codetitles} = &str2array($codetitles_str);
+        %{$cat_titles} = &str2hash($cat_titles_str);
+        %{$cat_order} = &str2hash($cat_order_str);
+        return 'ok';
+    }
+    return $response;
+}
+
 # ------------------------------------------------------------------ Plain Text
 
 sub plaintext {
@@ -3384,7 +3489,7 @@ sub modifyuser {
 
 sub modifystudent {
     my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
-        $end,$start,$forceid,$desiredhome,$email,$type,$cid)=@_;
+        $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid)=@_;
     if (!$cid) {
 	unless ($cid=$ENV{'request.course.id'}) {
 	    return 'not_in_class';
@@ -3399,13 +3504,12 @@ sub modifystudent {
     # students environment
     $uid = undef if (!$forceid);
     $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
-					$gene,$usec,$end,$start,$type,$cid);
+					$gene,$usec,$end,$start,$type,$locktype,$cid);
     return $reply;
 }
 
 sub modify_student_enrollment {
-    my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,
-	$cid) = @_;
+    my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid) = @_;
     my ($cdom,$cnum,$chome);
     if (!$cid) {
 	unless ($cid=$ENV{'request.course.id'}) {
@@ -3451,7 +3555,7 @@ sub modify_student_enrollment {
                                                            $first,$middle);
     my $reply=cput('classlist',
 		   {"$uname:$udom" => 
-			join(':',$end,$start,$uid,$usec,$fullname,$type) },
+			join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) },
 		   $cdom,$cnum);
     unless (($reply eq 'ok') || ($reply eq 'delayed')) {
 	return 'error: '.$reply;
@@ -3487,7 +3591,7 @@ sub writecoursepref {
 # ---------------------------------------------------------- Make/modify course
 
 sub createcourse {
-    my ($udom,$description,$url,$course_server,$nonstandard)=@_;
+    my ($udom,$description,$url,$course_server,$nonstandard,$inst_code)=@_;
     $url=&declutter($url);
     my $cid='';
     unless (&allowed('ccc',$udom)) {
@@ -3520,9 +3624,9 @@ sub createcourse {
 	return 'error: no such course';
     }
 # ----------------------------------------------------------------- Course made
-# log existance
-    &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description),
-                 $uhome);
+# log existence
+    &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description).
+                 '='.&escape($inst_code),$uhome);
     &flushcourselogs();
 # set toplevel url
     my $topurl=$url;
@@ -3575,28 +3679,12 @@ sub revokecustomrole {
            $deleteflag);
 }
 
-
-# ------------------------------------------------------------ Portfolio Director Lister
-sub portfoliolist {
-	# returns listing of contents of user's /userfiles/portfolio/ directory
-	# 
-	my ($udom, $uname, $uhome);
-	$uname=$ENV{'user.name'};
-        $udom=$ENV{'user.domain'};
-        $uhome=$ENV{'user.home'};
-	my $listing = reply('portls:'.$uname.':'.$udom, $uhome);
-	return $listing;
-}
-sub portfoliomanage {
-	# handles deleting and renaming files in user's userfiles/portfolio/ directory
-	# 
-	my ($filename, $fileaction, $filenewname) = @_;
-	my ($udom, $uname, $uhome);
-	$uname=$ENV{'user.name'};
-        $udom=$ENV{'user.domain'};
-        $uhome=$ENV{'user.home'};
-	my $listing = reply('portfoliomanage:'.$uname.':'.$udom.':'.$filename.':'.$fileaction.':'.$filenewname, $uhome);
-	return $listing;
+# ------------------------------------------------------------ Disk usage
+sub diskusage{
+    my ($udom,$uname,$directoryRoot)=@_;
+    $directoryRoot =~ s/\/$//;
+    my $listing=reply('du:'.$directoryRoot,homeserver($uname,$udom))
+    return $listing;
 }
 
 
@@ -4103,7 +4191,9 @@ sub metadata {
     my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
     $uri=&declutter($uri);
     # if it is a non metadata possible uri return quickly
-    if (($uri eq '') || (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|)) ||
+    if (($uri eq '') || 
+	(($uri =~ m|^/*adm/|) && 
+	     ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) ||
         ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||
 	($uri =~ m|home/[^/]+/public_html/|)) {
 	return undef;
@@ -4863,6 +4953,14 @@ sub getfile {
 	    if ($rtncode eq '404') {
 		unlink($localfile);
 	    }
+	    #my $ua=new LWP::UserAgent;
+	    #my $request=new HTTP::Request('GET',&tokenwrapper($file));
+	    #my $response=$ua->request($request);
+	    #if ($response->is_success()) {
+	#	return $response->content;
+	#    } else {
+	#	return -1;
+	#    }
 	    return -1;
 	}
 	if ($info < $fileinfo[9]) {
@@ -4876,12 +4974,19 @@ sub getfile {
     } else {
 	$lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode);
 	if ($lwpresp ne 'ok') {
-	    return -1;
+	    my $ua=new LWP::UserAgent;
+	    my $request=new HTTP::Request('GET',&tokenwrapper($file));
+	    my $response=$ua->request($request);
+	    if ($response->is_success()) {
+		return $response->content;
+	    } else {
+		return -1;
+	    }
 	}
 	my @parts = ($cdom,$cnum); 
 	if ($filename =~ m|^(.+)/[^/]+$|) {
 	    push @parts, split(/\//,$1);
-	    }
+	}
 	foreach my $part (@parts) {
 	    $path .= '/'.$part;
 	    if (!-e $path) {
@@ -4898,6 +5003,22 @@ sub getfile {
     return $info;
 }
 
+sub tokenwrapper {
+    my $uri=shift;
+    $uri=~s/^http\:\/\/([^\/]+)//;
+    $uri=~s/^\///;
+    $ENV{'user.environment'}=~/\/([^\/]+)\.id/;
+    my $token=$1;
+    if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) {
+        &appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'});
+        return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri.
+               (($uri=~/\?/)?'&':'?').'token='.$token.
+                               '&tokenissued='.$perlvar{'lonHostID'};
+    } else {
+        return '/adm/notfound.html';
+    }
+}
+
 sub getuploaded {
     my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
     $uri=~s/^\///;
@@ -4935,7 +5056,21 @@ sub filelocation {
     $location = $file;
     $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;
   } elsif ($file=~/^\/*uploaded/) { # is an uploaded file
-    $location=$file;
+      if ($file=~/^\/uploaded\/([^\/]+)\/([^\/]+)\/(\/)?simplepage\/([^\/]+)$/) {
+	  $location=&Apache::loncommon::propath($1,$2).'/userfiles/simplepage/'.$4;
+	  if (not -e $location) {
+	      $file=~/^\/uploaded\/(.*)$/;
+	      $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.$1;
+	  }
+      } elsif ($file=~/^\/uploaded\/([^\/]+)\/([^\/]+)\/aboutme\/([^\/]+)$/) {
+	  $location=&Apache::loncommon::propath($1,$2).'/userfiles/aboutme/'.$3;
+         if (not -e $location) {
+	     $file=~/^\/uploaded\/(.*)$/;
+	     $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.$1;
+         }
+      } else {
+	  $location=$file;
+      }
   } else {
     $file=~s/^\Q$perlvar{'lonDocRoot'}\E//;
     $file=~s:^/res/:/:;
@@ -5826,6 +5961,17 @@ 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)