--- loncom/lonnet/perl/lonnet.pm	2001/08/09 16:43:06	1.146
+++ loncom/lonnet/perl/lonnet.pm	2001/08/18 14:17:50	1.152
@@ -122,7 +122,7 @@
 # 5/30 H. K. Ng
 # 6/1 Gerd Kortemeyer
 # July Guy Albertelli
-# 8/4,8/7,8/8,8/9 Gerd Kortemeyer
+# 8/4,8/7,8/8,8/9,8/11,8/16,8/17,8/18 Gerd Kortemeyer
 
 package Apache::lonnet;
 
@@ -131,7 +131,7 @@ use Apache::File;
 use LWP::UserAgent();
 use HTTP::Headers;
 use vars 
-qw(%perlvar %hostname %homecache %spareid %hostdom %libserv %pr %prp %fe %fd $readit %metacache %packagetab);
+qw(%perlvar %hostname %homecache %hostip %spareid %hostdom %libserv %pr %prp %fe %fd $readit %metacache %packagetab);
 use IO::Socket;
 use GDBM_File;
 use Apache::Constants qw(:common :http);
@@ -276,7 +276,8 @@ sub appenv {
     map {
 	if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) {
             &logthis("<font color=blue>WARNING: ".
-                "Attempt to modify environment ".$_." to ".$newenv{$_});
+                "Attempt to modify environment ".$_." to ".$newenv{$_}
+                .'</font>');
 	    delete($newenv{$_});
         } else {
             $ENV{$_}=$newenv{$_};
@@ -659,6 +660,81 @@ sub log {
     return critical("log:$dom:$nam:$what",$hom);
 }
 
+# ----------------------------------------------------------- Check out an item
+
+sub checkout {
+    my ($symb,$tuname,$tudom,$tcrsid)=@_;
+    my $now=time;
+    my $lonhost=$perlvar{'lonHostID'};
+    my $infostr=&escape(
+                 $tuname.'&'.
+                 $tudom.'&'.
+                 $tcrsid.'&'.
+                 $symb.'&'.
+		 $now.'&'.$ENV{'REMOTE_ADDR'});
+    my $token=&reply('tmpput:'.$infostr,$lonhost);
+    if ($token=~/^error\:/) { 
+        &logthis("<font color=blue>WARNING: ".
+                "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.
+                 "</font>");
+        return ''; 
+    }
+
+    $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/;
+    $token=~tr/a-z/A-Z/;
+
+    my %infohash=('outtoken' => $token,
+                  'checkouttime' => $now,
+                  'outremote' => $ENV{'REMOTE_ADDR'});
+
+    unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
+       return '';
+    } else {
+        &logthis("<font color=blue>WARNING: ".
+                "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.
+                 "</font>");
+    }    
+
+    if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
+                         &escape('Checkout '.$infostr.' - '.
+                                                 $token)) ne 'ok') {
+	return '';
+    } else {
+        &logthis("<font color=blue>WARNING: ".
+                "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.
+                 "</font>");
+    }
+    return $token;
+}
+
+# ------------------------------------------------------------ Check in an item
+
+sub checkin {
+    my $token=shift;
+    my $now=time;
+    my ($ta,$tb,$lonhost)=split(/\*/,$token);
+    $lonhost=~tr/A-Z/a-z/;
+    my $dtoken=$ta.'_'.$hostip{$lonhost}.'_'.$tb;
+    $dtoken=~s/\W/\_/g;
+    my ($tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
+                 split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
+
+    my %infohash=('intoken' => $token,
+                  'checkintime' => $now,
+                  'inremote' => $ENV{'REMOTE_ADDR'});
+
+    unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
+       return '';
+    }    
+
+    if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
+                         &escape('Checkin - '.$token)) ne 'ok') {
+	return '';
+    }
+
+    return ($symb,$tuname,$tudom,$tcrsid);    
+}
+
 # --------------------------------------------- Set Expire Date for Spreadsheet
 
 sub expirespread {
@@ -1035,6 +1111,8 @@ sub eget {
 
 sub allowed {
     my ($priv,$uri)=@_;
+
+    my $orguri=$uri;
     $uri=&declutter($uri);
 
 # Free bre access to adm and meta resources
@@ -1108,16 +1186,27 @@ sub allowed {
            }
        }
        
-       if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) {
-	  my $refuri=$ENV{'HTTP_REFERER'};
-          $refuri=~s/^http\:\/\/$ENV{'request.host'}//i;
-          $refuri=&declutter($refuri);
+       if ($checkreferer) {
+	  my $refuri=$ENV{'httpref.'.$orguri};
+
+            unless ($refuri) {
+                map {
+		    if ($_=~/^httpref\..*\*/) {
+			my $pattern=$_;
+                        $pattern=~s/\*/\[\^\/\]\+/g;
+                        $pattern=~s/\//\\\//g;
+                        if ($orguri=~/$pattern/) {
+			    $refuri=$ENV{$_};
+                        }
+                    }
+                } keys %ENV;
+            }
+         if ($refuri) { 
+	  $refuri=&declutter($refuri);
           my @uriparts=split(/\//,$refuri);
           my $filename=$uriparts[$#uriparts];
           my $pathname=$refuri;
           $pathname=~s/\/$filename$//;
-          my @filenameparts=split(/\./,$uri);
-          if (&fileembstyle($filenameparts[$#filenameparts]) ne 'ssi') {
             if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
               /\&$filename\:([\d\|]+)\&/) {
               my $refstatecond=$1;
@@ -1127,8 +1216,8 @@ sub allowed {
                   $uri=$refuri;
                   $statecond=$refstatecond;
               }
-            }
           }
+        }
        }
    }
 
@@ -1674,7 +1763,7 @@ sub condval {
 # --------------------------------------------------------- Value of a Variable
 
 sub EXT {
-    my $varname=shift;
+    my ($varname,$symbparm)=@_;
     unless ($varname) { return ''; }
     my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);
     my $rest;
@@ -1740,7 +1829,12 @@ sub EXT {
 
 
 # ----------------------------------------------------- Cascading lookup scheme
-         my $symbp=&symbread();
+         my $symbp;
+         if ($symbparm) {
+            $symbp=$symbparm;
+	 } else {
+            $symbp=&symbread();
+         }            
          my $mapp=(split(/\_\_\_/,$symbp))[0];
 
          my $symbparm=$symbp.'.'.$spacequalifierrest;
@@ -1833,10 +1927,12 @@ sub EXT {
       unless ($space eq '0') {
           my ($part,$id)=split(/\_/,$space);
           if ($id) {
-	      my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest);
+	      my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
+                                   $symbparm);
               if ($partgeneral) { return $partgeneral; }
           } else {
-              my $resourcegeneral=&EXT('resource.0.'.$qualifierrest);
+              my $resourcegeneral=&EXT('resource.0.'.$qualifierrest,
+                                       $symbparm);
               if ($resourcegeneral) { return $resourcegeneral; }
           }
       }
@@ -2171,6 +2267,7 @@ if ($readit ne 'done') {
        my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
        $hostname{$id}=$name;
        $hostdom{$id}=$domain;
+       $hostip{$id}=$ip;
        if ($role eq 'library') { $libserv{$id}=$name; }
     }
 }