version 1.147, 2001/08/09 19:28:47
|
version 1.151, 2001/08/17 19:50:28
|
Line 122
|
Line 122
|
# 5/30 H. K. Ng |
# 5/30 H. K. Ng |
# 6/1 Gerd Kortemeyer |
# 6/1 Gerd Kortemeyer |
# July Guy Albertelli |
# 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 Gerd Kortemeyer |
|
|
package Apache::lonnet; |
package Apache::lonnet; |
|
|
Line 131 use Apache::File;
|
Line 131 use Apache::File;
|
use LWP::UserAgent(); |
use LWP::UserAgent(); |
use HTTP::Headers; |
use HTTP::Headers; |
use vars |
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 IO::Socket; |
use GDBM_File; |
use GDBM_File; |
use Apache::Constants qw(:common :http); |
use Apache::Constants qw(:common :http); |
Line 276 sub appenv {
|
Line 276 sub appenv {
|
map { |
map { |
if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) { |
if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) { |
&logthis("<font color=blue>WARNING: ". |
&logthis("<font color=blue>WARNING: ". |
"Attempt to modify environment ".$_." to ".$newenv{$_}); |
"Attempt to modify environment ".$_." to ".$newenv{$_} |
|
.'</font>'); |
delete($newenv{$_}); |
delete($newenv{$_}); |
} else { |
} else { |
$ENV{$_}=$newenv{$_}; |
$ENV{$_}=$newenv{$_}; |
Line 659 sub log {
|
Line 660 sub log {
|
return critical("log:$dom:$nam:$what",$hom); |
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 |
# --------------------------------------------- Set Expire Date for Spreadsheet |
|
|
sub expirespread { |
sub expirespread { |
Line 1108 sub allowed {
|
Line 1184 sub allowed {
|
} |
} |
} |
} |
|
|
if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) { |
if ($checkreferer) { |
my $refuri=$ENV{'HTTP_REFERER'}; |
my $refuri=$ENV{'httpref.'.$uri}; |
$refuri=~s/^http\:\/\/$ENV{'request.host'}//i; |
|
$refuri=&declutter($refuri); |
unless ($refuri) { |
|
map { |
|
if ($_=~/^httpref\..*\*/) { |
|
my $pattern=$_; |
|
$pattern=~s/\*/\[\^\/\]\+/g; |
|
$pattern=~s/\//\\\//g; |
|
if ($uri=~/$pattern/) { |
|
$refuri=$ENV{$_}; |
|
} |
|
} |
|
} keys %ENV; |
|
} |
|
if ($refuri) { |
my @uriparts=split(/\//,$refuri); |
my @uriparts=split(/\//,$refuri); |
my $filename=$uriparts[$#uriparts]; |
my $filename=$uriparts[$#uriparts]; |
my $pathname=$refuri; |
my $pathname=$refuri; |
Line 1129 sub allowed {
|
Line 1217 sub allowed {
|
} |
} |
} |
} |
} |
} |
|
} |
} |
} |
} |
} |
|
|
Line 2178 if ($readit ne 'done') {
|
Line 2267 if ($readit ne 'done') {
|
my ($id,$domain,$role,$name,$ip)=split(/:/,$configline); |
my ($id,$domain,$role,$name,$ip)=split(/:/,$configline); |
$hostname{$id}=$name; |
$hostname{$id}=$name; |
$hostdom{$id}=$domain; |
$hostdom{$id}=$domain; |
|
$hostip{$id}=$ip; |
if ($role eq 'library') { $libserv{$id}=$name; } |
if ($role eq 'library') { $libserv{$id}=$name; } |
} |
} |
} |
} |