--- loncom/lonnet/perl/lonnet.pm 2003/11/12 21:37:33 1.450
+++ loncom/lonnet/perl/lonnet.pm 2004/03/16 21:29:31 1.478
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.450 2003/11/12 21:37:33 matthew Exp $
+# $Id: lonnet.pm,v 1.478 2004/03/16 21:29:31 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -377,7 +377,12 @@ sub delenv {
return 'error: '.$!;
}
foreach (@oldenv) {
- unless ($_=~/^$delthis/) { print $fh $_; }
+ if ($_=~/^$delthis/) {
+ my ($key,undef) = split('=',$_);
+ delete($ENV{$key});
+ } else {
+ print $fh $_;
+ }
}
close($fh);
}
@@ -506,38 +511,16 @@ sub changepass {
sub queryauthenticate {
my ($uname,$udom)=@_;
- if (($perlvar{'lonRole'} eq 'library') &&
- ($udom eq $perlvar{'lonDefDomain'})) {
- my $answer=reply("encrypt:currentauth:$udom:$uname",
- $perlvar{'lonHostID'});
- unless ($answer eq 'unknown_user' or $answer eq 'refused') {
- if (length($answer)) {
- return $answer;
- }
- else {
- &logthis("User $uname at $udom lacks an authentication mechanism");
- return 'no_host';
- }
- }
- }
-
- my $tryserver;
- foreach $tryserver (keys %libserv) {
- if ($hostdom{$tryserver} eq $udom) {
- my $answer=reply("encrypt:currentauth:$udom:$uname",$tryserver);
- unless ($answer eq 'unknown_user' or $answer eq 'refused') {
- if (length($answer)) {
- return $answer;
- }
- else {
- &logthis("User $uname at $udom lacks an authentication mechanism");
- return 'no_host';
- }
- }
- }
+ my $uhome=&homeserver($uname,$udom);
+ if (!$uhome) {
+ &logthis("User $uname at $udom is unknown when looking for authentication mechanism");
+ return 'no_host';
+ }
+ my $answer=reply("encrypt:currentauth:$udom:$uname",$uhome);
+ if ($answer =~ /^(unknown_user|refused|con_lost)/) {
+ &logthis("User $uname at $udom threw error $answer when checking authentication mechanism");
}
- &logthis("User $uname at $udom lacks an authentication mechanism");
- return 'no_host';
+ return $answer;
}
# --------- Try to authenticate user from domain's lib servers (first this one)
@@ -546,38 +529,21 @@ sub authenticate {
my ($uname,$upass,$udom)=@_;
$upass=escape($upass);
$uname=~s/\W//g;
- if (($perlvar{'lonRole'} eq 'library') &&
- ($udom eq $perlvar{'lonDefDomain'})) {
- my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'});
- if ($answer =~ /authorized/) {
- if ($answer eq 'authorized') {
- &logthis("User $uname at $udom authorized by local server");
- return $perlvar{'lonHostID'};
- }
- if ($answer eq 'non_authorized') {
- &logthis("User $uname at $udom rejected by local server");
- return 'no_host';
- }
- }
- }
-
- my $tryserver;
- foreach $tryserver (keys %libserv) {
- if ($hostdom{$tryserver} eq $udom) {
- my $answer=reply("encrypt:auth:$udom:$uname:$upass",$tryserver);
- if ($answer =~ /authorized/) {
- if ($answer eq 'authorized') {
- &logthis("User $uname at $udom authorized by $tryserver");
- return $tryserver;
- }
- if ($answer eq 'non_authorized') {
- &logthis("User $uname at $udom rejected by $tryserver");
- return 'no_host';
- }
- }
- }
+ my $uhome=&homeserver($uname,$udom);
+ if (!$uhome) {
+ &logthis("User $uname at $udom is unknown in authenticate");
+ return 'no_host';
+ }
+ my $answer=reply("encrypt:auth:$udom:$uname:$upass",$uhome);
+ if ($answer eq 'authorized') {
+ &logthis("User $uname at $udom authorized by $uhome");
+ return $uhome;
+ }
+ if ($answer eq 'non_authorized') {
+ &logthis("User $uname at $udom rejected by $uhome");
+ return 'no_host';
}
- &logthis("User $uname at $udom could not be authenticated");
+ &logthis("User $uname at $udom threw error $answer when checking authentication mechanism");
return 'no_host';
}
@@ -848,10 +814,14 @@ sub getsection {
return '-1';
}
+
+my $disk_caching_disabled=1;
+
sub devalidate_cache {
my ($cache,$id,$name) = @_;
delete $$cache{$id.'.time'};
delete $$cache{$id};
+ if ($disk_caching_disabled) { return; }
my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
open(DB,"$filename.lock");
flock(DB,LOCK_EX);
@@ -907,6 +877,7 @@ sub do_cache {
sub save_cache_item {
my ($cache,$name,$id)=@_;
+ if ($disk_caching_disabled) { return; }
my $starttime=&Time::HiRes::time();
# &logthis("Saving :$name:$id");
my %hash;
@@ -936,6 +907,7 @@ EVALBLOCK
sub load_cache_item {
my ($cache,$name,$id)=@_;
+ if ($disk_caching_disabled) { return; }
my $starttime=&Time::HiRes::time();
# &logthis("Before Loading $name for $id size is ".scalar(%$cache));
my %hash;
@@ -1153,8 +1125,8 @@ sub ssi_body {
my ($filelink,%form)=@_;
my $output=($filelink=~/^http\:/?&externalssi($filelink):
&ssi($filelink,%form));
- $output=~s/^.*\<body[^\>]*\>//si;
- $output=~s/\<\/body\s*\>.*$//si;
+ $output=~s/^.*?\<body[^\>]*\>//si;
+ $output=~s/(.*)\<\/body\s*\>.*?$/$1/si;
$output=~
s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs;
return $output;
@@ -1199,7 +1171,8 @@ sub tokenwrapper {
$uri=~s/^\///;
$ENV{'user.environment'}=~/\/([^\/]+)\.id/;
my $token=$1;
- if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) {
+# if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) {
+ if ($uri=~m|^uploaded/([^/]+)/([^/]+)/(.+)(\?\.*)*$|) {
&appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'});
return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri.
(($uri=~/\?/)?'&':'?').'token='.$token.
@@ -1208,7 +1181,65 @@ sub tokenwrapper {
return '/adm/notfound.html';
}
}
-
+
+# --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course
+# input: action, courseID, current domain, home server for course, intended
+# path to file, source of file.
+# output: ok if successful, diagnostic message otherwise
+#
+# Allows directory structure to be used within lonUsers/../userfiles/ for a
+# course.
+#
+# action = propagate - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
+# will be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles in
+# course's home server.
+#
+# action = copy - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file will
+# be copied from $source (current location) to
+# /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
+# and will then be copied to
+# /home/httpd/lonUsers/$domain/1/2/3/$course/userfiles/$file in
+# course's home server.
+
+sub process_coursefile {
+ my ($action,$docuname,$docudom,$docuhome,$file,$source)=@_;
+ my $fetchresult;
+ if ($action eq 'propagate') {
+ $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file
+ ,$docuhome);
+ } elsif ($action eq 'copy') {
+ my $fetchresult = '';
+ my $fpath = '';
+ my $fname = $file;
+ ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|);
+ $fpath=$docudom.'/'.$docuname.'/'.$fpath;
+ my $filepath=$perlvar{'lonDocRoot'}.'/userfiles';
+ unless ($fpath eq '') {
+ my @parts=split('/',$fpath);
+ foreach my $part (@parts) {
+ $filepath.= '/'.$part;
+ if ((-e $filepath)!=1) {
+ mkdir($filepath,0777);
+ }
+ }
+ }
+ if ($source eq '') {
+ $fetchresult = 'no source file';
+ } else {
+ my $destination = $filepath.'/'.$fname;
+ print STDERR "Getting ready to rename $source to $destination\n";
+ rename($source,$destination);
+ $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
+ $docuhome);
+ }
+ }
+ unless ( ($fetchresult eq 'ok') || ($fetchresult eq 'no source file') ) {
+ &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
+ ' to host '.$docuhome.': '.$fetchresult);
+ }
+ 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
@@ -1264,9 +1295,8 @@ sub finishuserfileupload {
}
# Notify homeserver to grep it
#
-
- my $fetchresult=
- &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,$docuhome);
+ my $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,
+ $docuhome);
if ($fetchresult eq 'ok') {
#
# Return the URL to it
@@ -1335,8 +1365,15 @@ sub flushcourselogs {
# Writes to the dynamic metadata of resources to get hit counts, etc.
#
foreach my $entry (keys(%accesshash)) {
- my ($dom,$name,undef,$type)=($entry=~m:___(\w+)/(\w+)/(.*)___(\w+)$:);
- if ($type eq 'count'){
+ if ($entry =~ /___count$/) {
+ my ($dom,$name);
+ ($dom,$name,undef)=($entry=~m:___(\w+)/(\w+)/(.*)___count$:);
+ if (! defined($dom) || $dom eq '' ||
+ ! defined($name) || $name eq '') {
+ my $cid = $ENV{'request.course.id'};
+ $dom = $ENV{'request.'.$cid.'.domain'};
+ $name = $ENV{'request.'.$cid.'.num'};
+ }
my $value = $accesshash{$entry};
my (undef,$url,undef) = ($entry =~ /^(.*)___(.*)___count$/);
my %temphash=($url => $value);
@@ -1351,6 +1388,7 @@ sub flushcourselogs {
}
}
} else {
+ my ($dom,$name) = ($entry=~m:___(\w+)/(\w+)/(.*)___(\w+)$:);
my %temphash=($entry => $accesshash{$entry});
if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {
delete $accesshash{$entry};
@@ -1391,8 +1429,7 @@ sub courselog {
} else {
$courselogs{$ENV{'request.course.id'}}.=$what;
}
-# if (length($courselogs{$ENV{'request.course.id'}})>4048) {
- if (length($courselogs{$ENV{'request.course.id'}})>48) {
+ if (length($courselogs{$ENV{'request.course.id'}})>4048) {
&flushcourselogs();
}
}
@@ -1414,6 +1451,7 @@ sub courseacclog {
sub countacc {
my $url=&declutter(shift);
+ return if (! defined($url) || $url eq '');
unless ($ENV{'request.course.id'}) { return ''; }
$accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1;
my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count';
@@ -1432,7 +1470,7 @@ sub userrolelog {
my ($trole,$username,$domain,$area,$tstart,$tend)=@_;
if (($trole=~/^ca/) || ($trole=~/^in/) ||
($trole=~/^cc/) || ($trole=~/^ep/) ||
- ($trole=~/^cr/)) {
+ ($trole=~/^cr/) || ($trole=~/^ta/)) {
my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
$userrolehash
{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
@@ -1444,6 +1482,10 @@ sub get_course_adv_roles {
my $cid=shift;
$cid=$ENV{'request.course.id'} unless (defined($cid));
my %coursehash=&coursedescription($cid);
+ my %nothide=();
+ foreach (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
+ $nothide{join(':',split(/[\@\:]/,$_))}=1;
+ }
my %returnhash=();
my %dumphash=
&dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});
@@ -1454,6 +1496,8 @@ sub get_course_adv_roles {
if (($tend) && ($tend<$now)) { next; }
if (($tstart) && ($now<$tstart)) { next; }
my ($role,$username,$domain,$section)=split(/\:/,$_);
+ if ((&privileged($username,$domain)) &&
+ (!$nothide{$username.':'.$domain})) { next; }
my $key=&plaintext($role);
if ($section) { $key.=' (Sec/Grp '.$section.')'; }
if ($returnhash{$key}) {
@@ -2135,6 +2179,36 @@ sub coursedescription {
return %returnhash;
}
+# -------------------------------------------------See if a user is privileged
+
+sub privileged {
+ my ($username,$domain)=@_;
+ my $rolesdump=&reply("dump:$domain:$username:roles",
+ &homeserver($username,$domain));
+ if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return 0; }
+ my $now=time;
+ if ($rolesdump ne '') {
+ foreach (split(/&/,$rolesdump)) {
+ if ($_!~/^rolesdef\&/) {
+ my ($area,$role)=split(/=/,$_);
+ $area=~s/\_\w\w$//;
+ my ($trole,$tend,$tstart)=split(/_/,$role);
+ if (($trole eq 'dc') || ($trole eq 'su')) {
+ my $active=1;
+ if ($tend) {
+ if ($tend<$now) { $active=0; }
+ }
+ if ($tstart) {
+ if ($tstart>$now) { $active=0; }
+ }
+ if ($active) { return 1; }
+ }
+ }
+ }
+ }
+ return 0;
+}
+
# -------------------------------------------------------- Get user privileges
sub rolesinit {
@@ -3138,10 +3212,11 @@ sub modifyuser {
sub modifystudent {
my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
- $end,$start,$forceid,$desiredhome,$email)=@_;
- my $cid='';
- unless ($cid=$ENV{'request.course.id'}) {
- return 'not_in_class';
+ $end,$start,$forceid,$desiredhome,$email,$type,$cid)=@_;
+ if (!$cid) {
+ unless ($cid=$ENV{'request.course.id'}) {
+ return 'not_in_class';
+ }
}
# --------------------------------------------------------------- Make the user
my $reply=&modifyuser
@@ -3151,24 +3226,34 @@ sub modifystudent {
# This will cause &modify_student_enrollment to get the uid from the
# students environment
$uid = undef if (!$forceid);
- $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,
- $last,$gene,$usec,$end,$start);
+ $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
+ $gene,$usec,$end,$start,$type,$cid);
return $reply;
}
sub modify_student_enrollment {
- my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start) = @_;
- # Get the course id from the environment
- my $cid='';
- unless ($cid=$ENV{'request.course.id'}) {
- return 'not_in_class';
+ my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,
+ $cid) = @_;
+ my ($cdom,$cnum,$chome);
+ if (!$cid) {
+ unless ($cid=$ENV{'request.course.id'}) {
+ return 'not_in_class';
+ }
+ $cdom=$ENV{'course.'.$cid.'.domain'};
+ $cnum=$ENV{'course.'.$cid.'.num'};
+ } else {
+ ($cdom,$cnum)=split(/_/,$cid);
+ }
+ $chome=$ENV{'course.'.$cid.'.home'};
+ if (!$chome) {
+ $chome=&homeserver($cnum,$cdom);
}
+ if (!$chome) { return 'unknown_course'; }
# Make sure the user exists
my $uhome=&homeserver($uname,$udom);
if (($uhome eq '') || ($uhome eq 'no_host')) {
return 'error: no such user';
}
- #
# Get student data if we were not given enough information
if (!defined($first) || $first eq '' ||
!defined($last) || $last eq '' ||
@@ -3181,9 +3266,9 @@ sub modify_student_enrollment {
['firstname','middlename','lastname', 'generation','id']
,$udom,$uname);
- foreach (keys(%tmp)) {
- &logthis("key $_ = ".$tmp{$_});
- }
+ #foreach (keys(%tmp)) {
+ # &logthis("key $_ = ".$tmp{$_});
+ #}
$first = $tmp{'firstname'} if (!defined($first) || $first eq '');
$middle = $tmp{'middlename'} if (!defined($middle) || $middle eq '');
$last = $tmp{'lastname'} if (!defined($last) || $last eq '');
@@ -3192,11 +3277,9 @@ sub modify_student_enrollment {
}
my $fullname = &Apache::loncoursedata::ProcessFullName($last,$gene,
$first,$middle);
- my $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'.
- $ENV{'course.'.$cid.'.num'}.':classlist:'.
- &escape($uname.':'.$udom).'='.
- &escape(join(':',$end,$start,$uid,$usec,$fullname)),
- $ENV{'course.'.$cid.'.home'});
+ my $value=&escape($uname.':'.$udom).'='.
+ &escape(join(':',$end,$start,$uid,$usec,$fullname,$type));
+ my $reply=critical('put:'.$cdom.':'.$cnum.':classlist:'.$value,$chome);
unless (($reply eq 'ok') || ($reply eq 'delayed')) {
return 'error: '.$reply;
}
@@ -3688,10 +3771,8 @@ sub EXT {
my $hashid="$udom:$uname";
my ($result,$cached)=&is_cached(\%userresdatacache,$hashid,
'userres');
- if (!defined($cached)) {
- my %resourcedata=&get('resourcedata',
- [$courselevelr,$courselevelm,
- $courselevel],$udom,$uname);
+ if (!defined($cached)) {
+ my %resourcedata=&dump('resourcedata',$udom,$uname);
$result=\%resourcedata;
&do_cache(\%userresdatacache,$hashid,$result,'userres');
}
@@ -3704,12 +3785,13 @@ sub EXT {
if ($$result{$courselevel}) {
return $$result{$courselevel}; }
} else {
- if ($tmp!~/No such file/) {
+ #error 2 occurs when the .db doesn't exist
+ if ($tmp!~/error: 2 /) {
&logthis("<font color=blue>WARNING:".
" Trying to get resource data for ".
$uname." at ".$udom.": ".
$tmp."</font>");
- } elsif ($tmp=~/error:No such file/) {
+ } elsif ($tmp=~/error: 2 /) {
&EXT_cache_set($udom,$uname);
} elsif ($tmp =~ /^(con_lost|no_such_host)/) {
return $tmp;
@@ -3791,9 +3873,12 @@ sub packages_tab_default {
my $packages=&metadata($uri,'packages');
foreach my $package (split(/,/,$packages)) {
my ($pack_type,$pack_part)=split(/_/,$package,2);
- if ($pack_part eq $part) {
+ if (defined($packagetab{"$pack_type&$name&default"})) {
return $packagetab{"$pack_type&$name&default"};
}
+ if (defined($packagetab{$pack_type."_".$pack_part."&$name&default"})) {
+ return $packagetab{$pack_type."_".$pack_part."&$name&default"};
+ }
}
return undef;
}
@@ -3822,8 +3907,8 @@ sub metadata {
# if it is a non metadata possible uri return quickly
if (($uri eq '') || (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|)) ||
($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||
- ($uri =~ m|home/[^/]+/public_html/|)) {
- return '';
+ ($uri =~ m|home/[^/]+/public_html/|) || ($uri =~ m|^uploaded/|)) {
+ return undef;
}
my $filename=$uri;
$uri=~s/\.meta$//;
@@ -3840,7 +3925,9 @@ sub metadata {
#
# Is this a recursive call for a library?
#
- my %lcmetacache;
+ if (! exists($metacache{$uri})) {
+ $metacache{$uri}={};
+ }
if ($liburi) {
$liburi=&declutter($liburi);
$filename=$liburi;
@@ -3864,10 +3951,10 @@ sub metadata {
if (defined($token->[2]->{'id'})) {
$keyroot.='_'.$token->[2]->{'id'};
}
- if ($lcmetacache{':packages'}) {
- $lcmetacache{':packages'}.=','.$package.$keyroot;
+ if ($metacache{$uri}->{':packages'}) {
+ $metacache{$uri}->{':packages'}.=','.$package.$keyroot;
} else {
- $lcmetacache{':packages'}=$package.$keyroot;
+ $metacache{$uri}->{':packages'}=$package.$keyroot;
}
foreach (keys %packagetab) {
my $part=$keyroot;
@@ -3889,14 +3976,14 @@ sub metadata {
if ($subp eq 'display') {
$value.=' [Part: '.$part.']';
}
- $lcmetacache{':'.$unikey.'.part'}=$part;
+ $metacache{$uri}->{':'.$unikey.'.part'}=$part;
$metathesekeys{$unikey}=1;
- unless (defined($lcmetacache{':'.$unikey.'.'.$subp})) {
- $lcmetacache{':'.$unikey.'.'.$subp}=$value;
+ unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) {
+ $metacache{$uri}->{':'.$unikey.'.'.$subp}=$value;
}
- if (defined($lcmetacache{':'.$unikey.'.default'})) {
- $lcmetacache{':'.$unikey}=
- $lcmetacache{':'.$unikey.'.default'};
+ if (defined($metacache{$uri}->{':'.$unikey.'.default'})) {
+ $metacache{$uri}->{':'.$unikey}=
+ $metacache{$uri}->{':'.$unikey.'.default'};
}
}
}
@@ -3929,6 +4016,7 @@ sub metadata {
foreach (sort(split(/\,/,&metadata($uri,'keys',
$location,$unikey,
$depthcount+1)))) {
+ $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_};
$metathesekeys{$_}=1;
}
}
@@ -3939,18 +4027,18 @@ sub metadata {
}
$metathesekeys{$unikey}=1;
foreach (@{$token->[3]}) {
- $lcmetacache{':'.$unikey.'.'.$_}=$token->[2]->{$_};
+ $metacache{$uri}->{':'.$unikey.'.'.$_}=$token->[2]->{$_};
}
my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));
- my $default=$lcmetacache{':'.$unikey.'.default'};
+ my $default=$metacache{$uri}->{':'.$unikey.'.default'};
if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) {
# only ws inside the tag, and not in default, so use default
# as value
- $lcmetacache{':'.$unikey}=$default;
+ $metacache{$uri}->{':'.$unikey}=$default;
} else {
# either something interesting inside the tag or default
# uninteresting
- $lcmetacache{':'.$unikey}=$internaltext;
+ $metacache{$uri}->{':'.$unikey}=$internaltext;
}
# end of not-a-package not-a-library import
}
@@ -3960,27 +4048,28 @@ sub metadata {
}
}
# are there custom rights to evaluate
- if ($lcmetacache{':copyright'} eq 'custom') {
+ if ($metacache{$uri}->{':copyright'} eq 'custom') {
#
# Importing a rights file here
#
unless ($depthcount) {
- my $location=$lcmetacache{':customdistributionfile'};
+ my $location=$metacache{$uri}->{':customdistributionfile'};
my $dir=$filename;
$dir=~s|[^/]*$||;
$location=&filelocation($dir,$location);
foreach (sort(split(/\,/,&metadata($uri,'keys',
$location,'_rights',
$depthcount+1)))) {
+ $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_};
$metathesekeys{$_}=1;
}
}
}
- $lcmetacache{':keys'}=join(',',keys %metathesekeys);
- &metadata_generate_part0(\%metathesekeys,\%lcmetacache,$uri);
- $lcmetacache{':allpossiblekeys'}=join(',',keys %metathesekeys);
- &do_cache(\%metacache,$uri,\%lcmetacache,'meta');
+ $metacache{$uri}->{':keys'}=join(',',keys %metathesekeys);
+ &metadata_generate_part0(\%metathesekeys,$metacache{$uri},$uri);
+ $metacache{$uri}->{':allpossiblekeys'}=join(',',keys %metathesekeys);
+ &do_cache(\%metacache,$uri,$metacache{$uri},'meta');
# this is the end of "was not already recently cached
}
return $metacache{$uri}->{':'.$what};
@@ -4367,49 +4456,83 @@ sub setup_random_from_rndseed {
}
}
+sub latest_receipt_algorithm_id {
+ return 'receipt2';
+}
+
sub ireceipt {
- my ($funame,$fudom,$fucourseid,$fusymb)=@_;
+ my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_;
my $cuname=unpack("%32C*",$funame);
my $cudom=unpack("%32C*",$fudom);
my $cucourseid=unpack("%32C*",$fucourseid);
my $cusymb=unpack("%32C*",$fusymb);
my $cunique=unpack("%32C*",$perlvar{'lonReceipt'});
- return unpack("%32C*",$perlvar{'lonHostID'}).'-'.
- ($cunique%$cuname+
- $cunique%$cudom+
- $cusymb%$cuname+
- $cusymb%$cudom+
- $cucourseid%$cuname+
- $cucourseid%$cudom);
+ my $cpart=unpack("%32S*",$part);
+ my $return =unpack("%32C*",$perlvar{'lonHostID'}).'-';
+ if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2' ||
+ $ENV{'request.state'} eq 'construct') {
+ &Apache::lonxml::debug("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname).
+ " and ".($cpart%$cudom));
+
+ $return.= ($cunique%$cuname+
+ $cunique%$cudom+
+ $cusymb%$cuname+
+ $cusymb%$cudom+
+ $cucourseid%$cuname+
+ $cucourseid%$cudom+
+ $cpart%$cuname+
+ $cpart%$cudom);
+ } else {
+ $return.= ($cunique%$cuname+
+ $cunique%$cudom+
+ $cusymb%$cuname+
+ $cusymb%$cudom+
+ $cucourseid%$cuname+
+ $cucourseid%$cudom);
+ }
+ return $return;
}
sub receipt {
- my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser();
- return &ireceipt($name,$domain,$courseid,$symb);
+ my ($part)=@_;
+ my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser();
+ return &ireceipt($name,$domain,$courseid,$symb,$part);
}
# ------------------------------------------------------------ Serves up a file
-# returns either the contents of the file or a -1
+# returns either the contents of the file or
+# -1 if the file doesn't exist
+# -2 if an error occured when trying to aqcuire the file
+
sub getfile {
- my $file=shift;
- if ($file=~/^\/*uploaded\//) { # user file
- 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;
- }
- } else { # normal file from res space
- &repcopy($file);
- if (! -e $file ) { return -1; };
- my $fh;
- open($fh,"<$file");
- my $a='';
- while (<$fh>) { $a .=$_; }
- return $a;
- }
+ my $file=shift;
+ if ($file=~/^\/*uploaded\//) { # user file
+ 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 {
+ #&logthis("Return Code is ".$response->code." for $file ".
+ # &tokenwrapper($file));
+ # 500 for ISE when tokenwrapper can't figure out what server to
+ # contact
+ # 503 when lonuploadacc can't contact the requested server
+ if ($response->code eq 503 || $response->code eq 500) {
+ return -2;
+ } else {
+ return -1;
+ }
+ }
+ } else { # normal file from res space
+ &repcopy($file);
+ if (! -e $file ) { return -1; };
+ my $fh;
+ open($fh,"<$file");
+ my $a='';
+ while (<$fh>) { $a .=$_; }
+ return $a;
+ }
}
sub filelocation {
@@ -4423,7 +4546,7 @@ sub filelocation {
$location=$file;
} else {
$file=~s/^$perlvar{'lonDocRoot'}//;
- $file=~s:^/*res::;
+ $file=~s:^/res/:/:;
if ( !( $file =~ m:^/:) ) {
$location = $dir. '/'.$file;
} else {
@@ -4432,19 +4555,47 @@ sub filelocation {
}
$location=~s://+:/:g; # remove duplicate /
while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..
+ while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./
return $location;
}
sub hreflocation {
my ($dir,$file)=@_;
- unless (($file=~/^http:\/\//i) || ($file=~/^\//)) {
- my $finalpath=filelocation($dir,$file);
- $finalpath=~s/^\/home\/httpd\/html//;
- $finalpath=~s-/home/(\w+)/public_html/-/~$1/-;
- return $finalpath;
- } else {
- return $file;
+ unless (($file=~m-^http://-i) || ($file=~m-^/-)) {
+ my $finalpath=filelocation($dir,$file);
+ $finalpath=~s-^/home/httpd/html--;
+ $finalpath=~s-^/home/(\w+)/public_html/-/~$1/-;
+ return $finalpath;
+ } elsif ($file=~m-^/home-) {
+ $file=~s-^/home/httpd/html--;
+ $file=~s-^/home/(\w+)/public_html/-/~$1/-;
+ return $file;
+ }
+ return $file;
+}
+
+sub current_machine_domains {
+ my $hostname=$hostname{$perlvar{'lonHostID'}};
+ my @domains;
+ while( my($id, $name) = each(%hostname)) {
+# &logthis("-$id-$name-$hostname-");
+ if ($hostname eq $name) {
+ push(@domains,$hostdom{$id});
+ }
+ }
+ return @domains;
+}
+
+sub current_machine_ids {
+ my $hostname=$hostname{$perlvar{'lonHostID'}};
+ my @ids;
+ while( my($id, $name) = each(%hostname)) {
+# &logthis("-$id-$name-$hostname-");
+ if ($hostname eq $name) {
+ push(@ids,$id);
+ }
}
+ return @ids;
}
# ------------------------------------------------------------- Declutters URLs