--- loncom/lonnet/perl/lonnet.pm	2007/10/03 19:57:26	1.918
+++ loncom/lonnet/perl/lonnet.pm	2007/12/05 20:08:52	1.930
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.918 2007/10/03 19:57:26 raeburn Exp $
+# $Id: lonnet.pm,v 1.930 2007/12/05 20:08:52 albertel Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -513,7 +513,6 @@ sub get_env_multiple {
 }
 
 # ------------------------------------------ Find out current server userload
-# there is a copy in lond
 sub userload {
     my $numusers=0;
     {
@@ -521,7 +520,8 @@ sub userload {
 	my $filename;
 	my $curtime=time;
 	while ($filename=readdir(LONIDS)) {
-	    if ($filename eq '.' || $filename eq '..') {next;}
+	    next if ($filename eq '.' || $filename eq '..');
+	    next if ($filename =~ /publicuser_\d+\.id/);
 	    my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
 	    if ($curtime-$mtime < 1800) { $numusers++; }
 	}
@@ -1047,7 +1047,7 @@ sub get_instuser {
 }
 
 sub inst_rulecheck {
-    my ($udom,$uname,$rules) = @_;
+    my ($udom,$uname,$id,$item,$rules) = @_;
     my %returnhash;
     if ($udom ne '') {
         if (ref($rules) eq 'ARRAY') {
@@ -1055,9 +1055,16 @@ sub inst_rulecheck {
             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,
+                my $response;
+                if ($item eq 'username') {                
+                    $response=&unescape(&reply('instrulecheck:'.&escape($udom).
+                                              ':'.&escape($uname).':'.$rulestr,
                                               $homeserver));
+                } elsif ($item eq 'id') {
+                    $response=&unescape(&reply('instidrulecheck:'.&escape($udom).
+                                              ':'.&escape($id).':'.$rulestr,
+                                              $homeserver));
+                }
                 if ($response ne 'refused') {
                     my @pairs=split(/\&/,$response);
                     foreach my $item (@pairs) {
@@ -1074,14 +1081,21 @@ sub inst_rulecheck {
 }
 
 sub inst_userrules {
-    my ($udom) = @_;
+    my ($udom,$check) = @_;
     my (%ruleshash,@ruleorder);
     if ($udom ne '') {
         my $homeserver=&domain($udom,'primary');
         if (($homeserver ne '') && ($homeserver ne 'no_host')) {
-            my $response=&reply('instuserrules:'.&escape($udom),
+            my $response;
+            if ($check eq 'id') {
+                $response=&reply('instidrules:'.&escape($udom),
+                                 $homeserver);
+            } else {
+                $response=&reply('instuserrules:'.&escape($udom),
                                  $homeserver);
+            }
             if (($response ne 'refused') && ($response ne 'error') && 
+                ($response ne 'unknown_cmd') && 
                 ($response ne 'no_such_host')) {
                 my ($hashitems,$orderitems) = split(/:/,$response);
                 my @pairs=split(/\&/,$hashitems);
@@ -1383,13 +1397,15 @@ sub do_cache_new {
 	$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; }
@@ -1619,7 +1635,7 @@ sub ssi_body {
                                      &ssi($filelink,%form));
     $output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s*(-->)?\s||gs;
     $output=~s/^.*?\<body[^\>]*\>//si;
-    $output=~s/(.*)\<\/body\s*\>.*?$/$1/si;
+    $output=~s/\<\/body\s*\>.*?$//si;
     return $output;
 }
 
@@ -2170,7 +2186,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') {
@@ -2183,12 +2199,12 @@ sub flushcourselogs {
                delete $courselogs{$crsid};
             }
         }
-        $courseidbuffer{$coursehombuf{$crsid}}{$crsid} = (
+        $courseidbuffer{$coursehombuf{$crsid}}{$crsid} = {
             'description' => &escape($coursedescrbuf{$crsid}),
-            'instcode'    => &escape($courseinstcodebuf{$crsid}),
+            'inst_code'    => &escape($courseinstcodebuf{$crsid}),
             'type'        => &escape($coursetypebuf{$crsid}),
             'owner'       => &escape($courseownerbuf{$crsid}),
-        );
+        };
     }
 #
 # Write course id database (reverse lookup) to homeserver of courses 
@@ -2196,7 +2212,8 @@ sub flushcourselogs {
 #
     foreach my $crs_home (keys(%courseidbuffer)) {
         my $response = &courseidput(&host_domain($crs_home),
-                                    $courseidbuffer{$crs_home},$crs_home);
+                                    $courseidbuffer{$crs_home},
+                                    $crs_home,'timeonly');
     }
 #
 # File accesses
@@ -2460,7 +2477,13 @@ sub get_my_roles {
         }
         if (ref($roles) eq 'ARRAY') {
             if (!grep(/^\Q$role\E$/,@{$roles})) {
-                next;
+                if ($role =~ /^cr\//) {
+                    if (!grep(/^cr$/,@{$roles})) {
+                        next;
+                    }
+                } else {
+                    next;
+                }
             }
         }
 	$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
@@ -2502,21 +2525,32 @@ sub getannounce {
 #
 
 sub courseidput {
-    my ($domain,$storehash,$coursehome)=@_;
-    my $items='';
-    my $now = time;
-    foreach my $item (keys(%$storehash)) {
-        $storehash->{$item}{'lasttime'} = $now;
-        $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
+    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);
     }
-    $items=~s/\&$//;
-    my $outcome = &reply('courseidputhash:'.$domain.':'.$items,$coursehome);
     if ($outcome eq 'unknown_cmd') {
         my $what;
         foreach my $cid (keys(%$storehash)) {
             $what .= &escape($cid).'=';
-            foreach my $item ('description','instcode','owner','type') {
-                $what .= $storehash->{$item}.':';
+            foreach my $item ('description','inst_code','owner','type') {
+                $what .= &escape($storehash->{$item}).':';
             }
             $what =~ s/\:$/&/;
         }
@@ -2528,7 +2562,8 @@ sub courseidput {
 }
 
 sub courseiddump {
-    my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_;
+    my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,
+        $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_;
     my $as_hash = 1;
     my %returnhash;
     if (!$domfilter) { $domfilter=''; }
@@ -2545,7 +2580,7 @@ sub courseiddump {
                          $sincefilter.':'.&escape($descfilter).':'.
                          &escape($instcodefilter).':'.&escape($ownerfilter).
                          ':'.&escape($coursefilter).':'.&escape($typefilter).
-                         ':'.&escape($regexp_ok).':'.$as_hash,$tryserver); 
+                         ':'.&escape($regexp_ok).':'.$as_hash,$tryserver);
                 my @pairs=split(/\&/,$rep);
                 foreach my $item (@pairs) {
                     my ($key,$value)=split(/\=/,$item,2);
@@ -2555,10 +2590,10 @@ sub courseiddump {
                     if (ref($result) eq 'HASH') {
                         $returnhash{$key}=$result;
                     } else {
-                        my @responses = split(/:/,$result);
-                        my @items = ('description','instcode','owner','type');
+                        my @responses = split(/:/,$value);
+                        my @items = ('description','inst_code','owner','type');
                         for (my $i=0; $i<@responses; $i++) {
-                            $returnhash{$key}{$items[$i]} = $responses[$i];
+                            $returnhash{$key}{$items[$i]} = &unescape($responses[$i]);
                         }
                     } 
                 }
@@ -2606,7 +2641,10 @@ sub get_domain_roles {
     if (undef($enddate) || $enddate eq '') {
         $enddate = '.';
     }
-    my $rolelist = join(':',@{$roles});
+    my $rolelist;
+    if (ref($roles) eq 'ARRAY') {
+        $rolelist = join(':',@{$roles});
+    }
     my %personnel = ();
 
     my %servers = &get_servers($dom,'library');
@@ -2632,7 +2670,9 @@ sub get_first_access {
     my ($symb,$courseid,$udom,$uname)=&whichuser();
     if ($argsymb) { $symb=$argsymb; }
     my ($map,$id,$res)=&decode_symb($symb);
-    if ($type eq 'map') {
+    if ($type eq 'course') {
+	$res='course';
+    } elsif ($type eq 'map') {
 	$res=&symbread($map);
     } else {
 	$res=$symb;
@@ -2645,7 +2685,9 @@ sub set_first_access {
     my ($type)=@_;
     my ($symb,$courseid,$udom,$uname)=&whichuser();
     my ($map,$id,$res)=&decode_symb($symb);
-    if ($type eq 'map') {
+    if ($type eq 'course') {
+	$res='course';
+    } elsif ($type eq 'map') {
 	$res=&symbread($map);
     } else {
 	$res=$symb;
@@ -5546,14 +5588,13 @@ sub createcourse {
 # log existence
     my $newcourse = {
                     $udom.'_'.$uname => {
-                                     description => &escape($description),
-                                     inst_code   => &escape($inst_code),
-                                     owner       => &escape($course_owner),
-                                     type        => &escape($crstype),
+                                     description => $description,
+                                     inst_code   => $inst_code,
+                                     owner       => $course_owner,
+                                     type        => $crstype,
                                                 },
                     };
-    &courseidput($udom,$newcourse);
-    &flushcourselogs();
+    &courseidput($udom,$newcourse,$uhome,'notime');
 # set toplevel url
     my $topurl=$url;
     unless ($nonstandard) {
@@ -6355,8 +6396,8 @@ sub resdata {
     }
     if (!ref($result)) { return $result; }    
     foreach my $item (@which) {
-	if (defined($result->{$item})) {
-	    return $result->{$item};
+	if (defined($result->{$item->[0]})) {
+	    return [$result->{$item->[0]},$item->[1]];
 	}
     }
     return undef;
@@ -6568,8 +6609,9 @@ sub EXT {
 # ----------------------------------------------------------- first, check user
 
 	    my $userreply=&resdata($uname,$udom,'user',
-				       ($courselevelr,$courselevelm,
-					$courselevel));
+				       ([$courselevelr,'resource'],
+					[$courselevelm,'map'     ],
+					[$courselevel, 'course'  ]));
 	    if (defined($userreply)) { return $userreply; }
 
 # ------------------------------------------------ second, check some of course
@@ -6577,15 +6619,17 @@ sub EXT {
             if (@groups > 0) {
                 $coursereply = &check_group_parms($courseid,\@groups,$symbparm,
                                        $mapparm,$spacequalifierrest);
-                if (defined($coursereply)) { return $coursereply; }
+                if (defined($coursereply)) { return &get_reply($coursereply); }
             }
 
 	    $coursereply=&resdata($env{'course.'.$courseid.'.num'},
-				     $env{'course.'.$courseid.'.domain'},
-				     'course',
-				     ($seclevelr,$seclevelm,$seclevel,
-				      $courselevelr));
-	    if (defined($coursereply)) { return $coursereply; }
+				  $env{'course.'.$courseid.'.domain'},
+				  'course',
+				  ([$seclevelr,   'resource'],
+				   [$seclevelm,   'map'     ],
+				   [$seclevel,    'course'  ],
+				   [$courselevelr,'resource']));
+	    if (defined($coursereply)) { return &get_reply($coursereply); }
 
 # ------------------------------------------------------ third, check map parms
 	    my %parmhash=();
@@ -6596,7 +6640,7 @@ sub EXT {
 		$thisparm=$parmhash{$symbparm};
 		untie(%parmhash);
 	    }
-	    if ($thisparm) { return $thisparm; }
+	    if ($thisparm) { return &get_reply([$thisparm,'resource']); }
 	}
 # ------------------------------------------ fourth, look in resource metadata
 
@@ -6609,18 +6653,19 @@ sub EXT {
 	    $filename=$env{'request.filename'};
 	}
 	my $metadata=&metadata($filename,$spacequalifierrest);
-	if (defined($metadata)) { return $metadata; }
+	if (defined($metadata)) { return &get_reply([$metadata,'resource']); }
 	$metadata=&metadata($filename,'parameter_'.$spacequalifierrest);
-	if (defined($metadata)) { return $metadata; }
+	if (defined($metadata)) { return &get_reply([$metadata,'resource']); }
 
-# ---------------------------------------------- fourth, look in rest pf course
+# ---------------------------------------------- fourth, look in rest of course
 	if ($symbparm && defined($courseid) && 
 	    $courseid eq $env{'request.course.id'}) {
 	    my $coursereply=&resdata($env{'course.'.$courseid.'.num'},
 				     $env{'course.'.$courseid.'.domain'},
 				     'course',
-				     ($courselevelm,$courselevel));
-	    if (defined($coursereply)) { return $coursereply; }
+				     ([$courselevelm,'map'   ],
+				      [$courselevel, 'course']));
+	    if (defined($coursereply)) { return &get_reply($coursereply); }
 	}
 # ------------------------------------------------------------------ Cascade up
 	unless ($space eq '0') {
@@ -6628,14 +6673,13 @@ sub EXT {
 	    my $id=pop(@parts);
 	    my $part=join('_',@parts);
 	    if ($part eq '') { $part='0'; }
-	    my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
+	    my @partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
 				 $symbparm,$udom,$uname,$section,1);
-	    if (defined($partgeneral)) { return $partgeneral; }
+	    if (@partgeneral) { return &get_reply(\@partgeneral); }
 	}
 	if ($recurse) { return undef; }
 	my $pack_def=&packages_tab_default($filename,$varname);
-	if (defined($pack_def)) { return $pack_def; }
-
+	if (defined($pack_def)) { return &get_reply([$pack_def,'resource']); }
 # ---------------------------------------------------- Any other user namespace
     } elsif ($realm eq 'environment') {
 # ----------------------------------------------------------------- environment
@@ -6663,15 +6707,23 @@ sub EXT {
     return '';
 }
 
+sub get_reply {
+    my ($reply_value) = @_;
+    if (wantarray) {
+	return @$reply_value;
+    }
+    return $reply_value->[0];
+}
+
 sub check_group_parms {
     my ($courseid,$groups,$symbparm,$mapparm,$what) = @_;
     my @groupitems = ();
     my $resultitem;
-    my @levels = ($symbparm,$mapparm,$what);
+    my @levels = ([$symbparm,'resource'],[$mapparm,'map'],[$what,'course']);
     foreach my $group (@{$groups}) {
         foreach my $level (@levels) {
-             my $item = $courseid.'.['.$group.'].'.$level;
-             push(@groupitems,$item);
+             my $item = $courseid.'.['.$group.'].'.$level->[0];
+             push(@groupitems,[$item,$level->[1]]);
         }
     }
     my $coursereply = &resdata($env{'course.'.$courseid.'.num'},
@@ -6764,8 +6816,11 @@ sub metadata {
     if (($uri eq '') || 
 	(($uri =~ m|^/*adm/|) && 
 	     ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) ||
-        ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||
-	($uri =~ m|home/$match_username/public_html/|)) {
+        ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) ) {
+	return undef;
+    }
+    if (($uri =~ /^~/ || $uri =~ m{home/$match_username/public_html/}) 
+	&& &Apache::lonxml::get_state('target') =~ /^(|meta)$/) {
 	return undef;
     }
     my $filename=$uri;
@@ -6786,6 +6841,7 @@ sub metadata {
 #	if (! exists($metacache{$uri})) {
 #	    $metacache{$uri}={};
 #	}
+	my $cachetime = 60*60;
         if ($liburi) {
 	    $liburi=&declutter($liburi);
             $filename=$liburi;
@@ -6796,7 +6852,13 @@ sub metadata {
         my %metathesekeys=();
         unless ($filename=~/\.meta$/) { $filename.='.meta'; }
 	my $metastring;
-	if ($uri !~ m -^(editupload)/-) {
+	if ($uri =~ /^~/ || $uri =~ m{home/$match_username/public_html/}) {
+	    my $which = &hreflocation('','/'.($liburi || $uri));
+	    $metastring = 
+		&Apache::lonnet::ssi_body($which,
+					  ('grade_target' => 'meta'));
+	    $cachetime = 1; # only want this cached in the child not long term
+	} elsif ($uri !~ m -^(editupload)/-) {
 	    my $file=&filelocation('',&clutter($filename));
 	    #push(@{$metaentry{$uri.'.file'}},$file);
 	    $metastring=&getfile($file);
@@ -6963,7 +7025,7 @@ sub metadata {
 	$metaentry{':keys'} = join(',',keys(%metathesekeys));
 	&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
 	$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);
-	&do_cache_new('meta',$uri,\%metaentry,60*60);
+	&do_cache_new('meta',$uri,\%metaentry,$cachetime);
 # this is the end of "was not already recently cached
     }
     return $metaentry{':'.$what};
@@ -7911,7 +7973,13 @@ sub filelocation {
         }
     }
     $location=~s://+:/:g; # remove duplicate /
-    while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..
+    while ($location=~m{/\.\./}) {
+	if ($location =~ m{/[^/]+/\.\./}) {
+	    $location=~ s{/[^/]+/\.\./}{/}g;
+	} else {
+	    $location=~ s{/\.\./}{/}g;
+	}
+    } #remove dir/..
     while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./
     return $location;
 }