|
version 1.567, 2004/11/10 19:03:04
|
version 1.587.2.3.2.14, 2005/02/16 22:57:33
|
|
Line 35 use HTTP::Headers;
|
Line 35 use HTTP::Headers;
|
| use HTTP::Date; |
use HTTP::Date; |
| # use Date::Parse; |
# use Date::Parse; |
| use vars |
use vars |
| qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom |
qw(%perlvar %hostname %badServerCache %hostip %iphost %spareid %hostdom |
| %libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache |
%libserv %pr %prp $memcache %packagetab |
| %courselogs %accesshash %userrolehash $processmarker $dumpcount |
%courselogs %accesshash %userrolehash $processmarker $dumpcount |
| %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseresdatacache |
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf |
| %userresdatacache %getsectioncache %domaindescription %domain_auth_def %domain_auth_arg_def |
%domaindescription %domain_auth_def %domain_auth_arg_def |
| %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit); |
%domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit); |
| |
|
| use IO::Socket; |
use IO::Socket; |
|
Line 50 use Fcntl qw(:flock);
|
Line 50 use Fcntl qw(:flock);
|
| use Apache::lonlocal; |
use Apache::lonlocal; |
| use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze); |
use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze); |
| use Time::HiRes qw( gettimeofday tv_interval ); |
use Time::HiRes qw( gettimeofday tv_interval ); |
| |
use Cache::Memcached; |
| my $readit; |
my $readit; |
| my $max_connection_retries = 10; # Or some such value. |
my $max_connection_retries = 10; # Or some such value. |
| |
|
|
Line 157 sub reply {
|
Line 158 sub reply {
|
| my ($cmd,$server)=@_; |
my ($cmd,$server)=@_; |
| unless (defined($hostname{$server})) { return 'no_such_host'; } |
unless (defined($hostname{$server})) { return 'no_such_host'; } |
| my $answer=subreply($cmd,$server); |
my $answer=subreply($cmd,$server); |
| if ($answer eq 'con_lost') { |
|
| #sleep 5; |
|
| #$answer=subreply($cmd,$server); |
|
| #if ($answer eq 'con_lost') { |
|
| # &logthis("Second attempt con_lost on $server"); |
|
| # my $peerfile="$perlvar{'lonSockDir'}/$server"; |
|
| # my $client=IO::Socket::UNIX->new(Peer =>"$peerfile", |
|
| # Type => SOCK_STREAM, |
|
| # Timeout => 10) |
|
| # or return "con_lost"; |
|
| # &logthis("Killing socket"); |
|
| # print $client "close_connection_exit\n"; |
|
| #sleep 5; |
|
| # $answer=subreply($cmd,$server); |
|
| #} |
|
| } |
|
| if (($answer=~/^refused/) || ($answer=~/^rejected/)) { |
if (($answer=~/^refused/) || ($answer=~/^rejected/)) { |
| &logthis("<font color=blue>WARNING:". |
&logthis("<font color=blue>WARNING:". |
| " $cmd to $server returned $answer</font>"); |
" $cmd to $server returned $answer</font>"); |
|
Line 220 sub critical {
|
Line 205 sub critical {
|
| } |
} |
| my $answer=reply($cmd,$server); |
my $answer=reply($cmd,$server); |
| if ($answer eq 'con_lost') { |
if ($answer eq 'con_lost') { |
| my $pingreply=reply('ping',$server); |
|
| &reconlonc("$perlvar{'lonSockDir'}/$server"); |
&reconlonc("$perlvar{'lonSockDir'}/$server"); |
| my $pongreply=reply('pong',$server); |
my $answer=reply($cmd,$server); |
| &logthis("Ping/Pong for $server: $pingreply/$pongreply"); |
|
| $answer=reply($cmd,$server); |
|
| if ($answer eq 'con_lost') { |
if ($answer eq 'con_lost') { |
| my $now=time; |
my $now=time; |
| my $middlename=$cmd; |
my $middlename=$cmd; |
|
Line 577 sub authenticate {
|
Line 559 sub authenticate {
|
| |
|
| # ---------------------- Find the homebase for a user from domain's lib servers |
# ---------------------- Find the homebase for a user from domain's lib servers |
| |
|
| |
my %homecache; |
| sub homeserver { |
sub homeserver { |
| my ($uname,$udom,$ignoreBadCache)=@_; |
my ($uname,$udom,$ignoreBadCache)=@_; |
| my $index="$uname:$udom"; |
my $index="$uname:$udom"; |
| |
|
| my ($result,$cached)=&is_cached(\%homecache,$index,'home',86400); |
if (exists($homecache{$index})) { return $homecache{$index}; } |
| if (defined($cached)) { return $result; } |
|
| my $tryserver; |
my $tryserver; |
| foreach $tryserver (keys %libserv) { |
foreach $tryserver (keys %libserv) { |
| next if ($ignoreBadCache ne 'true' && |
next if ($ignoreBadCache ne 'true' && |
|
Line 590 sub homeserver {
|
Line 572 sub homeserver {
|
| if ($hostdom{$tryserver} eq $udom) { |
if ($hostdom{$tryserver} eq $udom) { |
| my $answer=reply("home:$udom:$uname",$tryserver); |
my $answer=reply("home:$udom:$uname",$tryserver); |
| if ($answer eq 'found') { |
if ($answer eq 'found') { |
| return &do_cache(\%homecache,$index,$tryserver,'home'); |
return $homecache{$index}=$tryserver; |
| } elsif ($answer eq 'no_host') { |
} elsif ($answer eq 'no_host') { |
| $badServerCache{$tryserver}=1; |
$badServerCache{$tryserver}=1; |
| } |
} |
|
Line 795 sub validate_access_key {
|
Line 777 sub validate_access_key {
|
| |
|
| sub getsection { |
sub getsection { |
| my ($udom,$unam,$courseid)=@_; |
my ($udom,$unam,$courseid)=@_; |
| |
my $cachetime=1800; |
| $courseid=~s/\_/\//g; |
$courseid=~s/\_/\//g; |
| $courseid=~s/^(\w)/\/$1/; |
$courseid=~s/^(\w)/\/$1/; |
| |
|
| my $hashid="$udom:$unam:$courseid"; |
my $hashid="$udom:$unam:$courseid"; |
| my ($result,$cached)=&is_cached(\%getsectioncache,$hashid,'getsection'); |
my ($result,$cached)=&is_cached_new('getsection',$hashid); |
| if (defined($cached)) { return $result; } |
if (defined($cached)) { return $result; } |
| |
|
| my %Pending; |
my %Pending; |
|
Line 834 sub getsection {
|
Line 817 sub getsection {
|
| $Pending{$start}=$section; |
$Pending{$start}=$section; |
| next; |
next; |
| } |
} |
| return &do_cache(\%getsectioncache,$hashid,$section,'getsection'); |
return &do_cache_new('getsection',$hashid,$section,$cachetime); |
| } |
} |
| # |
# |
| # Presumedly there will be few matching roles from the above |
# Presumedly there will be few matching roles from the above |
| # loop and the sorting time will be negligible. |
# loop and the sorting time will be negligible. |
| if (scalar(keys(%Pending))) { |
if (scalar(keys(%Pending))) { |
| my ($time) = sort {$a <=> $b} keys(%Pending); |
my ($time) = sort {$a <=> $b} keys(%Pending); |
| return &do_cache(\%getsectioncache,$hashid,$Pending{$time},'getsection'); |
return &do_cache_new('getsection',$hashid,$Pending{$time},$cachetime); |
| } |
} |
| if (scalar(keys(%Expired))) { |
if (scalar(keys(%Expired))) { |
| my @sorted = sort {$a <=> $b} keys(%Expired); |
my @sorted = sort {$a <=> $b} keys(%Expired); |
| my $time = pop(@sorted); |
my $time = pop(@sorted); |
| return &do_cache(\%getsectioncache,$hashid,$Expired{$time},'getsection'); |
return &do_cache_new('getsection',$hashid,$Expired{$time},$cachetime); |
| } |
} |
| return &do_cache(\%getsectioncache,$hashid,'-1','getsection'); |
return &do_cache_new('getsection',$hashid,'-1',$cachetime); |
| } |
} |
| |
|
| |
|
|
Line 942 sub save_cache_item {
|
Line 925 sub save_cache_item {
|
| } |
} |
| |
|
| sub save_cache { |
sub save_cache { |
| |
&purge_remembered(); |
| if ($disk_caching_disabled) { return; } |
if ($disk_caching_disabled) { return; } |
| my ($cache,$name,$id); |
my ($cache,$name,$id); |
| foreach $name (keys(%do_save)) { |
foreach $name (keys(%do_save)) { |
|
Line 1039 EVALBLOCK
|
Line 1023 EVALBLOCK
|
| # &logthis("load_cache_item $name took ".(&Time::HiRes::time()-$starttime)); |
# &logthis("load_cache_item $name took ".(&Time::HiRes::time()-$starttime)); |
| } |
} |
| |
|
| |
my $to_remember=-1; |
| |
my %remembered; |
| |
my %accessed; |
| |
my $kicks=0; |
| |
my $hits=0; |
| |
sub devalidate_cache_new { |
| |
my ($name,$id,$debug) = @_; |
| |
if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); } |
| |
$id=&escape($name.':'.$id); |
| |
$memcache->delete($id); |
| |
delete($remembered{$id}); |
| |
delete($accessed{$id}); |
| |
} |
| |
|
| |
sub is_cached_new { |
| |
my ($name,$id,$debug) = @_; |
| |
$id=&escape($name.':'.$id); |
| |
if (exists($remembered{$id})) { |
| |
if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); } |
| |
$accessed{$id}=[&gettimeofday()]; |
| |
$hits++; |
| |
return ($remembered{$id},1); |
| |
} |
| |
my $value = $memcache->get($id); |
| |
if (!(defined($value))) { |
| |
if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); } |
| |
return (undef,undef); |
| |
} |
| |
if ($value eq '__undef__') { |
| |
if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); } |
| |
$value=undef; |
| |
} |
| |
&make_room($id,$value,$debug); |
| |
if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); } |
| |
return ($value,1); |
| |
} |
| |
|
| |
sub do_cache_new { |
| |
my ($name,$id,$value,$time,$debug) = @_; |
| |
$id=&escape($name.':'.$id); |
| |
my $setvalue=$value; |
| |
if (!defined($setvalue)) { |
| |
$setvalue='__undef__'; |
| |
} |
| |
if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); } |
| |
$memcache->set($id,$setvalue,300); |
| |
&make_room($id,$value,$debug); |
| |
return $value; |
| |
} |
| |
|
| |
sub make_room { |
| |
my ($id,$value,$debug)=@_; |
| |
$remembered{$id}=$value; |
| |
if ($to_remember<0) { return; } |
| |
$accessed{$id}=[&gettimeofday()]; |
| |
if (scalar(keys(%remembered)) <= $to_remember) { return; } |
| |
my $to_kick; |
| |
my $max_time=0; |
| |
foreach my $other (keys(%accessed)) { |
| |
if (&tv_interval($accessed{$other}) > $max_time) { |
| |
$to_kick=$other; |
| |
$max_time=&tv_interval($accessed{$other}); |
| |
} |
| |
} |
| |
delete($remembered{$to_kick}); |
| |
delete($accessed{$to_kick}); |
| |
$kicks++; |
| |
if ($debug) { &logthis("kicking $max_time $kicks\n"); } |
| |
return; |
| |
} |
| |
|
| |
sub purge_remembered { |
| |
&logthis("Tossing ".scalar(keys(%remembered))); |
| |
&logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered)))); |
| |
undef(%remembered); |
| |
undef(%accessed); |
| |
} |
| # ------------------------------------- Read an entry from a user's environment |
# ------------------------------------- Read an entry from a user's environment |
| |
|
| sub userenvironment { |
sub userenvironment { |
|
Line 1076 sub getversion {
|
Line 1137 sub getversion {
|
| |
|
| sub currentversion { |
sub currentversion { |
| my $fname=shift; |
my $fname=shift; |
| my ($result,$cached)=&is_cached(\%resversioncache,$fname,'resversion',600); |
my ($result,$cached)=&is_cached_new('resversion',$fname); |
| if (defined($cached)) { return $result; } |
if (defined($cached)) { return $result; } |
| my $author=$fname; |
my $author=$fname; |
| $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; |
$author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; |
|
Line 1089 sub currentversion {
|
Line 1150 sub currentversion {
|
| if (($answer eq 'con_lost') || ($answer eq 'rejected')) { |
if (($answer eq 'con_lost') || ($answer eq 'rejected')) { |
| return -1; |
return -1; |
| } |
} |
| return &do_cache(\%resversioncache,$fname,$answer,'resversion'); |
return &do_cache_new('resversion',$fname,$answer,600); |
| } |
} |
| |
|
| # ----------------------------- Subscribe to a resource, return URL if possible |
# ----------------------------- Subscribe to a resource, return URL if possible |
|
Line 1406 sub finishuserfileupload {
|
Line 1467 sub finishuserfileupload {
|
| } |
} |
| # Save the file |
# Save the file |
| { |
{ |
| #&Apache::lonnet::logthis("Saving to $filepath $file"); |
open(FH,'>'.$filepath.'/'.$file); |
| open(my $fh,'>'.$filepath.'/'.$file); |
print FH $ENV{'form.'.$formname}; |
| print $fh $ENV{'form.'.$formname}; |
close(FH); |
| close($fh); |
|
| } |
} |
| # Notify homeserver to grep it |
# Notify homeserver to grep it |
| # |
# |
| |
&Apache::lonnet::logthis("fetching ".$path.$file); |
| my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome); |
my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome); |
| if ($fetchresult eq 'ok') { |
if ($fetchresult eq 'ok') { |
| # |
# |
|
Line 1490 sub flushcourselogs {
|
Line 1551 sub flushcourselogs {
|
| if ($courseidbuffer{$coursehombuf{$crsid}}) { |
if ($courseidbuffer{$coursehombuf{$crsid}}) { |
| $courseidbuffer{$coursehombuf{$crsid}}.='&'. |
$courseidbuffer{$coursehombuf{$crsid}}.='&'. |
| &escape($crsid).'='.&escape($coursedescrbuf{$crsid}). |
&escape($crsid).'='.&escape($coursedescrbuf{$crsid}). |
| '='.&escape($courseinstcodebuf{$crsid}); |
':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}); |
| } else { |
} else { |
| $courseidbuffer{$coursehombuf{$crsid}}= |
$courseidbuffer{$coursehombuf{$crsid}}= |
| &escape($crsid).'='.&escape($coursedescrbuf{$crsid}). |
&escape($crsid).'='.&escape($coursedescrbuf{$crsid}). |
| '='.&escape($courseinstcodebuf{$crsid}); |
':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}); |
| } |
} |
| } |
} |
| # |
# |
| # Write course id database (reverse lookup) to homeserver of courses |
# Write course id database (reverse lookup) to homeserver of courses |
|
Line 1570 sub courselog {
|
Line 1631 sub courselog {
|
| $ENV{'course.'.$ENV{'request.course.id'}.'.description'}; |
$ENV{'course.'.$ENV{'request.course.id'}.'.description'}; |
| $courseinstcodebuf{$ENV{'request.course.id'}}= |
$courseinstcodebuf{$ENV{'request.course.id'}}= |
| $ENV{'course.'.$ENV{'request.course.id'}.'.internal.coursecode'}; |
$ENV{'course.'.$ENV{'request.course.id'}.'.internal.coursecode'}; |
| |
$courseownerbuf{$ENV{'request.course.id'}}= |
| |
$ENV{'course.'.$ENV{'request.course.id'}.'.internal.courseowner'}; |
| if (defined $courselogs{$ENV{'request.course.id'}}) { |
if (defined $courselogs{$ENV{'request.course.id'}}) { |
| $courselogs{$ENV{'request.course.id'}}.='&'.$what; |
$courselogs{$ENV{'request.course.id'}}.='&'.$what; |
| } else { |
} else { |
|
Line 1586 sub courseacclog {
|
Line 1649 sub courseacclog {
|
| my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'}; |
my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'}; |
| if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|page)$/) { |
if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|page)$/) { |
| $what.=':POST'; |
$what.=':POST'; |
| |
# FIXME: Probably ought to escape things.... |
| foreach (keys %ENV) { |
foreach (keys %ENV) { |
| if ($_=~/^form\.(.*)/) { |
if ($_=~/^form\.(.*)/) { |
| $what.=':'.$1.'='.$ENV{$_}; |
$what.=':'.$1.'='.$ENV{$_}; |
| } |
} |
| } |
} |
| |
} elsif ($fnsymb =~ m:^/adm/searchcat:) { |
| |
# FIXME: We should not be depending on a form parameter that someone |
| |
# editing lonsearchcat.pm might change in the future. |
| |
if ($ENV{'form.phase'} eq 'course_search') { |
| |
$what.= ':POST'; |
| |
# FIXME: Probably ought to escape things.... |
| |
foreach my $element ('courseexp','crsfulltext','crsrelated', |
| |
'crsdiscuss') { |
| |
$what.=':'.$element.'='.$ENV{'form.'.$element}; |
| |
} |
| |
} |
| } |
} |
| &courselog($what); |
&courselog($what); |
| } |
} |
|
Line 1642 sub get_course_adv_roles {
|
Line 1717 sub get_course_adv_roles {
|
| if (($tend) && ($tend<$now)) { next; } |
if (($tend) && ($tend<$now)) { next; } |
| if (($tstart) && ($now<$tstart)) { next; } |
if (($tstart) && ($now<$tstart)) { next; } |
| my ($role,$username,$domain,$section)=split(/\:/,$_); |
my ($role,$username,$domain,$section)=split(/\:/,$_); |
| |
if ($username eq '' || $domain eq '') { next; } |
| if ((&privileged($username,$domain)) && |
if ((&privileged($username,$domain)) && |
| (!$nothide{$username.':'.$domain})) { next; } |
(!$nothide{$username.':'.$domain})) { next; } |
| my $key=&plaintext($role); |
my $key=&plaintext($role); |
|
Line 1713 sub courseidput {
|
Line 1789 sub courseidput {
|
| } |
} |
| |
|
| sub courseiddump { |
sub courseiddump { |
| my ($domfilter,$descfilter,$sincefilter,$hostidflag,$hostidref)=@_; |
my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$hostidflag,$hostidref)=@_; |
| my %returnhash=(); |
my %returnhash=(); |
| unless ($domfilter) { $domfilter=''; } |
unless ($domfilter) { $domfilter=''; } |
| foreach my $tryserver (keys %libserv) { |
foreach my $tryserver (keys %libserv) { |
|
Line 1721 sub courseiddump {
|
Line 1797 sub courseiddump {
|
| if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) { |
if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) { |
| foreach ( |
foreach ( |
| split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'. |
split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'. |
| $sincefilter.':'.&escape($descfilter), |
$sincefilter.':'.&escape($descfilter).':'. |
| |
&escape($instcodefilter).':'.&escape($ownerfilter), |
| $tryserver))) { |
$tryserver))) { |
| my ($key,$value)=split(/\=/,$_); |
my ($key,$value)=split(/\=/,$_); |
| if (($key) && ($value)) { |
if (($key) && ($value)) { |
|
Line 2360 sub privileged {
|
Line 2437 sub privileged {
|
| my $now=time; |
my $now=time; |
| if ($rolesdump ne '') { |
if ($rolesdump ne '') { |
| foreach (split(/&/,$rolesdump)) { |
foreach (split(/&/,$rolesdump)) { |
| if ($_!~/^rolesdef\&/) { |
if ($_!~/^rolesdef_/) { |
| my ($area,$role)=split(/=/,$_); |
my ($area,$role)=split(/=/,$_); |
| $area=~s/\_\w\w$//; |
$area=~s/\_\w\w$//; |
| my ($trole,$tend,$tstart)=split(/_/,$role); |
my ($trole,$tend,$tstart)=split(/_/,$role); |
|
Line 2392 sub rolesinit {
|
Line 2469 sub rolesinit {
|
| |
|
| if ($rolesdump ne '') { |
if ($rolesdump ne '') { |
| foreach (split(/&/,$rolesdump)) { |
foreach (split(/&/,$rolesdump)) { |
| if ($_!~/^rolesdef\&/) { |
if ($_!~/^rolesdef_/) { |
| my ($area,$role)=split(/=/,$_); |
my ($area,$role)=split(/=/,$_); |
| $area=~s/\_\w\w$//; |
$area=~s/\_\w\w$//; |
| my ($trole,$tend,$tstart)=split(/_/,$role); |
|
| $userroles.=&set_arearole($trole,$area,$tstart,$tend); |
my ($trole,$tend,$tstart); |
| |
if ($role=~/^cr/) { |
| |
($trole,my $trest)=($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|); |
| |
($tend,$tstart)=split('_',$trest); |
| |
} else { |
| |
($trole,$tend,$tstart)=split(/_/,$role); |
| |
} |
| |
$userroles.=&set_arearole($trole,$area,$tstart,$tend,$domain,$username); |
| if (($tend!=0) && ($tend<$now)) { $trole=''; } |
if (($tend!=0) && ($tend<$now)) { $trole=''; } |
| if (($tstart!=0) && ($tstart>$now)) { $trole=''; } |
if (($tstart!=0) && ($tstart>$now)) { $trole=''; } |
| if (($area ne '') && ($trole ne '')) { |
if (($area ne '') && ($trole ne '')) { |
|
Line 2773 sub customaccess {
|
Line 2857 sub customaccess {
|
| # ------------------------------------------------- Check for a user privilege |
# ------------------------------------------------- Check for a user privilege |
| |
|
| sub allowed { |
sub allowed { |
| my ($priv,$uri)=@_; |
my ($priv,$uri,$symb)=@_; |
| $uri=&deversion($uri); |
$uri=&deversion($uri); |
| my $orguri=$uri; |
my $orguri=$uri; |
| $uri=&declutter($uri); |
$uri=&declutter($uri); |
|
Line 3054 sub allowed {
|
Line 3138 sub allowed {
|
| |
|
| if ($thisallowed=~/X/) { |
if ($thisallowed=~/X/) { |
| if ($ENV{'acc.randomout'}) { |
if ($ENV{'acc.randomout'}) { |
| my $symb=&symbread($uri,1); |
if (!$symb) { $symb=&symbread($uri,1); } |
| if (($symb) && ($ENV{'acc.randomout'}=~/\&\Q$symb\E\&/)) { |
if (($symb) && ($ENV{'acc.randomout'}=~/\&\Q$symb\E\&/)) { |
| return ''; |
return ''; |
| } |
} |
|
Line 3356 sub auto_instcode_format {
|
Line 3440 sub auto_instcode_format {
|
| my $courses = ''; |
my $courses = ''; |
| my $homeserver; |
my $homeserver; |
| if ($caller eq 'global') { |
if ($caller eq 'global') { |
| $homeserver = $perlvar{'lonHostID'}; |
foreach my $tryserver (keys %libserv) { |
| |
if ($hostdom{$tryserver} eq $codedom) { |
| |
$homeserver = $tryserver; |
| |
last; |
| |
} |
| |
} |
| |
if (($ENV{'user.name'}) && ($ENV{'user.domain'} eq $codedom)) { |
| |
$homeserver = &homeserver($ENV{'user.name'},$codedom); |
| |
} |
| } else { |
} else { |
| $homeserver = &homeserver($caller,$codedom); |
$homeserver = &homeserver($caller,$codedom); |
| } |
} |
| my $host=$hostname{$homeserver}; |
|
| foreach (keys %{$instcodes}) { |
foreach (keys %{$instcodes}) { |
| $courses .= &escape($_).'='.&escape($$instcodes{$_}).'&'; |
$courses .= &escape($_).'='.&escape($$instcodes{$_}).'&'; |
| } |
} |
|
Line 3687 sub writecoursepref {
|
Line 3778 sub writecoursepref {
|
| # ---------------------------------------------------------- Make/modify course |
# ---------------------------------------------------------- Make/modify course |
| |
|
| sub createcourse { |
sub createcourse { |
| my ($udom,$description,$url,$course_server,$nonstandard,$inst_code)=@_; |
my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,$course_owner)=@_; |
| $url=&declutter($url); |
$url=&declutter($url); |
| my $cid=''; |
my $cid=''; |
| unless (&allowed('ccc',$udom)) { |
unless (&allowed('ccc',$udom)) { |
|
Line 3722 sub createcourse {
|
Line 3813 sub createcourse {
|
| # ----------------------------------------------------------------- Course made |
# ----------------------------------------------------------------- Course made |
| # log existence |
# log existence |
| &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description). |
&courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description). |
| '='.&escape($inst_code),$uhome); |
':'.&escape($inst_code).':'.&escape($course_owner),$uhome); |
| &flushcourselogs(); |
&flushcourselogs(); |
| # set toplevel url |
# set toplevel url |
| my $topurl=$url; |
my $topurl=$url; |
|
Line 3809 sub mark_as_readonly {
|
Line 3900 sub mark_as_readonly {
|
| return; |
return; |
| } |
} |
| |
|
| |
# ------------------------------------------------------------Save Selected Files |
| |
|
| |
sub save_selected_files { |
| |
my ($user, $path, @files) = @_; |
| |
my $filename = $user."savedfiles"; |
| |
my @other_files = &files_not_in_path($user, $path); |
| |
open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); |
| |
foreach my $file (@files) { |
| |
print (OUT $ENV{'form.currentpath'}.$file."\n"); |
| |
} |
| |
foreach my $file (@other_files) { |
| |
print (OUT $file."\n"); |
| |
} |
| |
close (OUT); |
| |
return 'ok'; |
| |
} |
| |
|
| |
sub clear_selected_files { |
| |
my ($user) = @_; |
| |
my $filename = $user."savedfiles"; |
| |
open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); |
| |
print (OUT undef); |
| |
close (OUT); |
| |
return ("ok"); |
| |
} |
| |
|
| |
sub files_in_path { |
| |
my ($user, $path) = @_; |
| |
my $filename = $user."savedfiles"; |
| |
my %return_files; |
| |
open (IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); |
| |
while (my $line_in = <IN>) { |
| |
chomp ($line_in); |
| |
my @paths_and_file = split (m!/!, $line_in); |
| |
my $file_part = pop (@paths_and_file); |
| |
my $path_part = join ('/', @paths_and_file); |
| |
$path_part.='/'; |
| |
my $path_and_file = $path_part.$file_part; |
| |
if ($path_part eq $path) { |
| |
$return_files{$file_part}= 'selected'; |
| |
} |
| |
} |
| |
close (IN); |
| |
return (\%return_files); |
| |
} |
| |
|
| |
# called in portfolio select mode, to show files selected NOT in current directory |
| |
sub files_not_in_path { |
| |
my ($user, $path) = @_; |
| |
my $filename = $user."savedfiles"; |
| |
my @return_files; |
| |
my $path_part; |
| |
open (IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); |
| |
while (<IN>) { |
| |
#ok, I know it's clunky, but I want it to work |
| |
my @paths_and_file = split m!/!, $_; |
| |
my $file_part = pop (@paths_and_file); |
| |
chomp ($file_part); |
| |
my $path_part = join ('/', @paths_and_file); |
| |
$path_part .= '/'; |
| |
my $path_and_file = $path_part.$file_part; |
| |
if ($path_part ne $path) { |
| |
push (@return_files, ($path_and_file)); |
| |
} |
| |
} |
| |
close (OUT); |
| |
return (@return_files); |
| |
} |
| |
|
| #--------------------------------------------------------------Get Marked as Read Only |
#--------------------------------------------------------------Get Marked as Read Only |
| |
|
| sub get_marked_as_readonly { |
sub get_marked_as_readonly { |
|
Line 3828 sub get_marked_as_readonly {
|
Line 3988 sub get_marked_as_readonly {
|
| } |
} |
| return @readonly_files; |
return @readonly_files; |
| } |
} |
| |
#-----------------------------------------------------------Get Marked as Read Only Hash |
| |
|
| |
sub get_marked_as_readonly_hash { |
| |
my ($domain,$user,$what) = @_; |
| |
my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user); |
| |
my %readonly_files; |
| |
while (my ($file_name,$value) = each(%current_permissions)) { |
| |
if (ref($value) eq "ARRAY"){ |
| |
foreach my $stored_what (@{$value}) { |
| |
if ($stored_what eq $what) { |
| |
$readonly_files{$file_name} = 'locked'; |
| |
} elsif (!defined($what)) { |
| |
$readonly_files{$file_name} = 'locked'; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return %readonly_files; |
| |
} |
| # ------------------------------------------------------------ Unmark as Read Only |
# ------------------------------------------------------------ Unmark as Read Only |
| |
|
| sub unmark_as_readonly { |
sub unmark_as_readonly { |
|
Line 4024 sub condval {
|
Line 4202 sub condval {
|
| sub devalidatecourseresdata { |
sub devalidatecourseresdata { |
| my ($coursenum,$coursedomain)=@_; |
my ($coursenum,$coursedomain)=@_; |
| my $hashid=$coursenum.':'.$coursedomain; |
my $hashid=$coursenum.':'.$coursedomain; |
| &devalidate_cache(\%courseresdatacache,$hashid,'courseres'); |
&devalidate_cache_new('courseres',$hashid); |
| } |
} |
| |
|
| # --------------------------------------------------- Course Resourcedata Query |
# --------------------------------------------------- Course Resourcedata Query |
|
Line 4033 sub courseresdata {
|
Line 4211 sub courseresdata {
|
| my ($coursenum,$coursedomain,@which)=@_; |
my ($coursenum,$coursedomain,@which)=@_; |
| my $coursehom=&homeserver($coursenum,$coursedomain); |
my $coursehom=&homeserver($coursenum,$coursedomain); |
| my $hashid=$coursenum.':'.$coursedomain; |
my $hashid=$coursenum.':'.$coursedomain; |
| my ($result,$cached)=&is_cached(\%courseresdatacache,$hashid,'courseres'); |
my ($result,$cached)=&is_cached_new('courseres',$hashid); |
| unless (defined($cached)) { |
unless (defined($cached)) { |
| my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum); |
my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum); |
| $result=\%dumpreply; |
$result=\%dumpreply; |
| my ($tmp) = keys(%dumpreply); |
my ($tmp) = keys(%dumpreply); |
| if ($tmp !~ /^(con_lost|error|no_such_host)/i) { |
if ($tmp !~ /^(con_lost|error|no_such_host)/i) { |
| &do_cache(\%courseresdatacache,$hashid,$result,'courseres'); |
&do_cache_new('courseres',$hashid,$result,600); |
| } elsif ($tmp =~ /^(con_lost|no_such_host)/) { |
} elsif ($tmp =~ /^(con_lost|no_such_host)/) { |
| return $tmp; |
return $tmp; |
| } elsif ($tmp =~ /^(error)/) { |
} elsif ($tmp =~ /^(error)/) { |
| $result=undef; |
$result=undef; |
| &do_cache(\%courseresdatacache,$hashid,$result,'courseres'); |
&do_cache_new('courseres',$hashid,$result,600); |
| } |
} |
| } |
} |
| foreach my $item (@which) { |
foreach my $item (@which) { |
|
Line 4233 sub EXT {
|
Line 4411 sub EXT {
|
| #most student don\'t have any data set, check if there is some data |
#most student don\'t have any data set, check if there is some data |
| if (! &EXT_cache_status($udom,$uname)) { |
if (! &EXT_cache_status($udom,$uname)) { |
| my $hashid="$udom:$uname"; |
my $hashid="$udom:$uname"; |
| my ($result,$cached)=&is_cached(\%userresdatacache,$hashid, |
my ($result,$cached)=&is_cached_new('userres',$hashid); |
| 'userres'); |
|
| if (!defined($cached)) { |
if (!defined($cached)) { |
| my %resourcedata=&dump('resourcedata',$udom,$uname); |
my %resourcedata=&dump('resourcedata',$udom,$uname); |
| $result=\%resourcedata; |
$result=\%resourcedata; |
| &do_cache(\%userresdatacache,$hashid,$result,'userres'); |
&do_cache_new('userres',$hashid,$result); |
| } |
} |
| my ($tmp)=keys(%$result); |
my ($tmp)=keys(%$result); |
| if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) { |
if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) { |
|
Line 4340 sub packages_tab_default {
|
Line 4517 sub packages_tab_default {
|
| if (defined($packagetab{"$pack_type&$name&default"})) { |
if (defined($packagetab{"$pack_type&$name&default"})) { |
| return $packagetab{"$pack_type&$name&default"}; |
return $packagetab{"$pack_type&$name&default"}; |
| } |
} |
| |
if ($pack_type eq 'part') { $pack_part='0'; } |
| if (defined($packagetab{$pack_type."_".$pack_part."&$name&default"})) { |
if (defined($packagetab{$pack_type."_".$pack_part."&$name&default"})) { |
| return $packagetab{$pack_type."_".$pack_part."&$name&default"}; |
return $packagetab{$pack_type."_".$pack_part."&$name&default"}; |
| } |
} |
|
Line 4365 sub add_prefix_and_part {
|
Line 4543 sub add_prefix_and_part {
|
| |
|
| # ---------------------------------------------------------------- Get metadata |
# ---------------------------------------------------------------- Get metadata |
| |
|
| |
my %metaentry; |
| sub metadata { |
sub metadata { |
| my ($uri,$what,$liburi,$prefix,$depthcount)=@_; |
my ($uri,$what,$liburi,$prefix,$depthcount)=@_; |
| $uri=&declutter($uri); |
$uri=&declutter($uri); |
|
Line 4384 sub metadata {
|
Line 4563 sub metadata {
|
| # Everything is cached by the main uri, libraries are never directly cached |
# Everything is cached by the main uri, libraries are never directly cached |
| # |
# |
| if (!defined($liburi)) { |
if (!defined($liburi)) { |
| my ($result,$cached)=&is_cached(\%metacache,$uri,'meta'); |
my ($result,$cached)=&is_cached_new('meta',$uri); |
| if (defined($cached)) { return $result->{':'.$what}; } |
if (defined($cached)) { return $result->{':'.$what}; } |
| } |
} |
| { |
{ |
| # |
# |
| # Is this a recursive call for a library? |
# Is this a recursive call for a library? |
| # |
# |
| if (! exists($metacache{$uri})) { |
# if (! exists($metacache{$uri})) { |
| $metacache{$uri}={}; |
# $metacache{$uri}={}; |
| } |
# } |
| if ($liburi) { |
if ($liburi) { |
| $liburi=&declutter($liburi); |
$liburi=&declutter($liburi); |
| $filename=$liburi; |
$filename=$liburi; |
| } else { |
} else { |
| &devalidate_cache(\%metacache,$uri,'meta'); |
&devalidate_cache_new('meta',$uri); |
| |
undef(%metaentry); |
| } |
} |
| my %metathesekeys=(); |
my %metathesekeys=(); |
| unless ($filename=~/\.meta$/) { $filename.='.meta'; } |
unless ($filename=~/\.meta$/) { $filename.='.meta'; } |
| my $metastring; |
my $metastring; |
| if ($uri !~ m|^uploaded/|) { |
if ($uri !~ m|^uploaded/|) { |
| my $file=&filelocation('',&clutter($filename)); |
my $file=&filelocation('',&clutter($filename)); |
| push(@{$metacache{$uri.'.file'}},$file); |
#push(@{$metaentry{$uri.'.file'}},$file); |
| $metastring=&getfile($file); |
$metastring=&getfile($file); |
| } |
} |
| my $parser=HTML::LCParser->new(\$metastring); |
my $parser=HTML::LCParser->new(\$metastring); |
|
Line 4422 sub metadata {
|
Line 4602 sub metadata {
|
| if (defined($token->[2]->{'id'})) { |
if (defined($token->[2]->{'id'})) { |
| $keyroot.='_'.$token->[2]->{'id'}; |
$keyroot.='_'.$token->[2]->{'id'}; |
| } |
} |
| if ($metacache{$uri}->{':packages'}) { |
if ($metaentry{':packages'}) { |
| $metacache{$uri}->{':packages'}.=','.$package.$keyroot; |
$metaentry{':packages'}.=','.$package.$keyroot; |
| } else { |
} else { |
| $metacache{$uri}->{':packages'}=$package.$keyroot; |
$metaentry{':packages'}=$package.$keyroot; |
| } |
} |
| foreach (keys %packagetab) { |
foreach (keys %packagetab) { |
| my $part=$keyroot; |
my $part=$keyroot; |
|
Line 4447 sub metadata {
|
Line 4627 sub metadata {
|
| if ($subp eq 'display') { |
if ($subp eq 'display') { |
| $value.=' [Part: '.$part.']'; |
$value.=' [Part: '.$part.']'; |
| } |
} |
| $metacache{$uri}->{':'.$unikey.'.part'}=$part; |
$metaentry{':'.$unikey.'.part'}=$part; |
| $metathesekeys{$unikey}=1; |
$metathesekeys{$unikey}=1; |
| unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) { |
unless (defined($metaentry{':'.$unikey.'.'.$subp})) { |
| $metacache{$uri}->{':'.$unikey.'.'.$subp}=$value; |
$metaentry{':'.$unikey.'.'.$subp}=$value; |
| } |
} |
| if (defined($metacache{$uri}->{':'.$unikey.'.default'})) { |
if (defined($metaentry{':'.$unikey.'.default'})) { |
| $metacache{$uri}->{':'.$unikey}= |
$metaentry{':'.$unikey}= |
| $metacache{$uri}->{':'.$unikey.'.default'}; |
$metaentry{':'.$unikey.'.default'}; |
| } |
} |
| } |
} |
| } |
} |
|
Line 4487 sub metadata {
|
Line 4667 sub metadata {
|
| foreach (sort(split(/\,/,&metadata($uri,'keys', |
foreach (sort(split(/\,/,&metadata($uri,'keys', |
| $location,$unikey, |
$location,$unikey, |
| $depthcount+1)))) { |
$depthcount+1)))) { |
| $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_}; |
$metaentry{':'.$_}=$metaentry{':'.$_}; |
| $metathesekeys{$_}=1; |
$metathesekeys{$_}=1; |
| } |
} |
| } |
} |
|
Line 4498 sub metadata {
|
Line 4678 sub metadata {
|
| } |
} |
| $metathesekeys{$unikey}=1; |
$metathesekeys{$unikey}=1; |
| foreach (@{$token->[3]}) { |
foreach (@{$token->[3]}) { |
| $metacache{$uri}->{':'.$unikey.'.'.$_}=$token->[2]->{$_}; |
$metaentry{':'.$unikey.'.'.$_}=$token->[2]->{$_}; |
| } |
} |
| my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry)); |
my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry)); |
| my $default=$metacache{$uri}->{':'.$unikey.'.default'}; |
my $default=$metaentry{':'.$unikey.'.default'}; |
| if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) { |
if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) { |
| # only ws inside the tag, and not in default, so use default |
# only ws inside the tag, and not in default, so use default |
| # as value |
# as value |
| $metacache{$uri}->{':'.$unikey}=$default; |
$metaentry{':'.$unikey}=$default; |
| } else { |
} else { |
| # either something interesting inside the tag or default |
# either something interesting inside the tag or default |
| # uninteresting |
# uninteresting |
| $metacache{$uri}->{':'.$unikey}=$internaltext; |
$metaentry{':'.$unikey}=$internaltext; |
| } |
} |
| # end of not-a-package not-a-library import |
# end of not-a-package not-a-library import |
| } |
} |
|
Line 4526 sub metadata {
|
Line 4706 sub metadata {
|
| &metadata_create_package_def($uri,$key,'extension_'.$extension, |
&metadata_create_package_def($uri,$key,'extension_'.$extension, |
| \%metathesekeys); |
\%metathesekeys); |
| } |
} |
| if (!exists($metacache{$uri}->{':packages'})) { |
if (!exists($metaentry{':packages'})) { |
| foreach my $key (sort(keys(%packagetab))) { |
foreach my $key (sort(keys(%packagetab))) { |
| #no specific packages well let's get default then |
#no specific packages well let's get default then |
| if ($key!~/^default&/) { next; } |
if ($key!~/^default&/) { next; } |
|
Line 4535 sub metadata {
|
Line 4715 sub metadata {
|
| } |
} |
| } |
} |
| # are there custom rights to evaluate |
# are there custom rights to evaluate |
| if ($metacache{$uri}->{':copyright'} eq 'custom') { |
if ($metaentry{':copyright'} eq 'custom') { |
| |
|
| # |
# |
| # Importing a rights file here |
# Importing a rights file here |
| # |
# |
| unless ($depthcount) { |
unless ($depthcount) { |
| my $location=$metacache{$uri}->{':customdistributionfile'}; |
my $location=$metaentry{':customdistributionfile'}; |
| my $dir=$filename; |
my $dir=$filename; |
| $dir=~s|[^/]*$||; |
$dir=~s|[^/]*$||; |
| $location=&filelocation($dir,$location); |
$location=&filelocation($dir,$location); |
| foreach (sort(split(/\,/,&metadata($uri,'keys', |
foreach (sort(split(/\,/,&metadata($uri,'keys', |
| $location,'_rights', |
$location,'_rights', |
| $depthcount+1)))) { |
$depthcount+1)))) { |
| $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_}; |
#$metaentry{':'.$_}=$metacache{$uri}->{':'.$_}; |
| $metathesekeys{$_}=1; |
$metathesekeys{$_}=1; |
| } |
} |
| } |
} |
| } |
} |
| $metacache{$uri}->{':keys'}=join(',',keys %metathesekeys); |
$metaentry{':keys'}=join(',',keys %metathesekeys); |
| &metadata_generate_part0(\%metathesekeys,$metacache{$uri},$uri); |
&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri); |
| $metacache{$uri}->{':allpossiblekeys'}=join(',',keys %metathesekeys); |
$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys); |
| &do_cache(\%metacache,$uri,$metacache{$uri},'meta'); |
&do_cache_new('meta',$uri,\%metaentry); |
| # this is the end of "was not already recently cached |
# this is the end of "was not already recently cached |
| } |
} |
| return $metacache{$uri}->{':'.$what}; |
return $metaentry{':'.$what}; |
| } |
} |
| |
|
| sub metadata_create_package_def { |
sub metadata_create_package_def { |
|
Line 4567 sub metadata_create_package_def {
|
Line 4747 sub metadata_create_package_def {
|
| my ($pack,$name,$subp)=split(/\&/,$key); |
my ($pack,$name,$subp)=split(/\&/,$key); |
| if ($subp eq 'default') { next; } |
if ($subp eq 'default') { next; } |
| |
|
| if (defined($metacache{$uri}->{':packages'})) { |
if (defined($metaentry{':packages'})) { |
| $metacache{$uri}->{':packages'}.=','.$package; |
$metaentry{':packages'}.=','.$package; |
| } else { |
} else { |
| $metacache{$uri}->{':packages'}=$package; |
$metaentry{':packages'}=$package; |
| } |
} |
| my $value=$packagetab{$key}; |
my $value=$packagetab{$key}; |
| my $unikey; |
my $unikey; |
| $unikey='parameter_0_'.$name; |
$unikey='parameter_0_'.$name; |
| $metacache{$uri}->{':'.$unikey.'.part'}=0; |
$metaentry{':'.$unikey.'.part'}=0; |
| $$metathesekeys{$unikey}=1; |
$$metathesekeys{$unikey}=1; |
| unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) { |
unless (defined($metaentry{':'.$unikey.'.'.$subp})) { |
| $metacache{$uri}->{':'.$unikey.'.'.$subp}=$value; |
$metaentry{':'.$unikey.'.'.$subp}=$value; |
| } |
} |
| if (defined($metacache{$uri}->{':'.$unikey.'.default'})) { |
if (defined($metaentry{':'.$unikey.'.default'})) { |
| $metacache{$uri}->{':'.$unikey}= |
$metaentry{':'.$unikey}= |
| $metacache{$uri}->{':'.$unikey.'.default'}; |
$metaentry{':'.$unikey.'.default'}; |
| } |
} |
| } |
} |
| |
|
|
Line 4620 sub gettitle {
|
Line 4800 sub gettitle {
|
| my $urlsymb=shift; |
my $urlsymb=shift; |
| my $symb=&symbread($urlsymb); |
my $symb=&symbread($urlsymb); |
| if ($symb) { |
if ($symb) { |
| my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600); |
my $key=$ENV{'request.course.id'}."\0".$symb; |
| if (defined($cached)) { return $result; } |
my ($result,$cached)=&is_cached_new('title',$key); |
| |
if (defined($cached)) { |
| |
return $result; |
| |
} |
| my ($map,$resid,$url)=&decode_symb($symb); |
my ($map,$resid,$url)=&decode_symb($symb); |
| my $title=''; |
my $title=''; |
| my %bighash; |
my %bighash; |
|
Line 4633 sub gettitle {
|
Line 4816 sub gettitle {
|
| } |
} |
| $title=~s/\&colon\;/\:/gs; |
$title=~s/\&colon\;/\:/gs; |
| if ($title) { |
if ($title) { |
| return &do_cache(\%titlecache,$symb,$title,'title'); |
return &do_cache_new('title',$key,$title,600); |
| } |
} |
| $urlsymb=$url; |
$urlsymb=$url; |
| } |
} |
|
Line 4697 sub symbverify {
|
Line 4880 sub symbverify {
|
| if ( |
if ( |
| &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn) |
&symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn) |
| eq $symb) { |
eq $symb) { |
| $okay=1; |
if (($ENV{'request.role.adv'}) || |
| } |
$bighash{'encrypted_'.$_} eq $ENV{'request.enc'}) { |
| |
$okay=1; |
| |
} |
| |
} |
| } |
} |
| } |
} |
| untie(%bighash); |
untie(%bighash); |
|
Line 4710 sub symbverify {
|
Line 4896 sub symbverify {
|
| |
|
| sub symbclean { |
sub symbclean { |
| my $symb=shift; |
my $symb=shift; |
| |
if ($symb=~m|^/enc/|) { $symb=&Apache::lonenc::unencrypted($symb); } |
| # remove version from map |
# remove version from map |
| $symb=~s/\.(\d+)\.(\w+)\_\_\_/\.$2\_\_\_/; |
$symb=~s/\.(\d+)\.(\w+)\_\_\_/\.$2\_\_\_/; |
| |
|
|
Line 4731 sub encode_symb {
|
Line 4917 sub encode_symb {
|
| } |
} |
| |
|
| sub decode_symb { |
sub decode_symb { |
| my ($map,$resid,$url)=split(/\_\_\_/,shift); |
my $symb=shift; |
| |
if ($symb=~m|^/enc/|) { $symb=&Apache::lonenc::unencrypted($symb); } |
| |
my ($map,$resid,$url)=split(/___/,$symb); |
| return (&fixversion($map),$resid,&fixversion($url)); |
return (&fixversion($map),$resid,&fixversion($url)); |
| } |
} |
| |
|
|
Line 4742 sub fixversion {
|
Line 4930 sub fixversion {
|
| my $uri=&clutter($fn); |
my $uri=&clutter($fn); |
| my $key=$ENV{'request.course.id'}.'_'.$uri; |
my $key=$ENV{'request.course.id'}.'_'.$uri; |
| # is this cached? |
# is this cached? |
| my ($result,$cached)=&is_cached(\%courseresversioncache,$key, |
my ($result,$cached)=&is_cached_new('courseresversion',$key); |
| 'courseresversion',600); |
|
| if (defined($cached)) { return $result; } |
if (defined($cached)) { return $result; } |
| # unfortunately not cached, or expired |
# unfortunately not cached, or expired |
| if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', |
if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', |
|
Line 4757 sub fixversion {
|
Line 4944 sub fixversion {
|
| } |
} |
| untie %bighash; |
untie %bighash; |
| } |
} |
| return &do_cache |
return &do_cache_new('courseresversion',$key,&declutter($uri),600); |
| (\%courseresversioncache,$key,&declutter($uri),'courseresversion'); |
|
| } |
} |
| |
|
| sub deversion { |
sub deversion { |
|
Line 4780 sub symbread {
|
Line 4966 sub symbread {
|
| } |
} |
| $thisfn=$ENV{'request.filename'}; |
$thisfn=$ENV{'request.filename'}; |
| } |
} |
| |
if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); } |
| # is that filename actually a symb? Verify, clean, and return |
# is that filename actually a symb? Verify, clean, and return |
| if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) { |
if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) { |
| if (&symbverify($thisfn,$1)) { |
if (&symbverify($thisfn,$1)) { |
|
Line 4890 sub numval2 {
|
Line 5077 sub numval2 {
|
| return int($total); |
return int($total); |
| } |
} |
| |
|
| |
sub numval3 { |
| |
use integer; |
| |
my $txt=shift; |
| |
$txt=~tr/A-J/0-9/; |
| |
$txt=~tr/a-j/0-9/; |
| |
$txt=~tr/K-T/0-9/; |
| |
$txt=~tr/k-t/0-9/; |
| |
$txt=~tr/U-Z/0-5/; |
| |
$txt=~tr/u-z/0-5/; |
| |
$txt=~s/\D//g; |
| |
my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt); |
| |
my $total; |
| |
foreach my $val (@txts) { $total+=$val; } |
| |
if ($_64bit) { $total=(($total<<32)>>32); } |
| |
return $total; |
| |
} |
| |
|
| sub latest_rnd_algorithm_id { |
sub latest_rnd_algorithm_id { |
| return '64bit3'; |
return '64bit4'; |
| } |
} |
| |
|
| sub get_rand_alg { |
sub get_rand_alg { |
|
Line 4930 sub rndseed {
|
Line 5134 sub rndseed {
|
| if (!$username) { $username=$wusername } |
if (!$username) { $username=$wusername } |
| my $which=&get_rand_alg(); |
my $which=&get_rand_alg(); |
| if (defined(&getCODE())) { |
if (defined(&getCODE())) { |
| return &rndseed_CODE_64bit($symb,$courseid,$domain,$username); |
if ($which eq '64bit4') { |
| |
return &rndseed_CODE_64bit4($symb,$courseid,$domain,$username); |
| |
} else { |
| |
return &rndseed_CODE_64bit($symb,$courseid,$domain,$username); |
| |
} |
| |
} elsif ($which eq '64bit4') { |
| |
return &rndseed_64bit4($symb,$courseid,$domain,$username); |
| } elsif ($which eq '64bit3') { |
} elsif ($which eq '64bit3') { |
| return &rndseed_64bit3($symb,$courseid,$domain,$username); |
return &rndseed_64bit3($symb,$courseid,$domain,$username); |
| } elsif ($which eq '64bit2') { |
} elsif ($which eq '64bit2') { |
|
Line 5027 sub rndseed_64bit3 {
|
Line 5237 sub rndseed_64bit3 {
|
| } |
} |
| } |
} |
| |
|
| |
sub rndseed_64bit4 { |
| |
my ($symb,$courseid,$domain,$username)=@_; |
| |
{ |
| |
use integer; |
| |
# strings need to be an even # of cahracters long, it it is odd the |
| |
# last characters gets thrown away |
| |
my $symbchck=unpack("%32S*",$symb.' ') << 21; |
| |
my $symbseed=numval3($symb) << 10; |
| |
my $namechck=unpack("%32S*",$username.' '); |
| |
|
| |
my $nameseed=numval3($username) << 21; |
| |
my $domainseed=unpack("%32S*",$domain.' ') << 10; |
| |
my $courseseed=unpack("%32S*",$courseid.' '); |
| |
|
| |
my $num1=$symbchck+$symbseed+$namechck; |
| |
my $num2=$nameseed+$domainseed+$courseseed; |
| |
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
| |
#&Apache::lonxml::debug("rndseed :$num1:$num2:$_64bit"); |
| |
if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } |
| |
|
| |
return "$num1:$num2"; |
| |
} |
| |
} |
| |
|
| sub rndseed_CODE_64bit { |
sub rndseed_CODE_64bit { |
| my ($symb,$courseid,$domain,$username)=@_; |
my ($symb,$courseid,$domain,$username)=@_; |
| { |
{ |
|
Line 5046 sub rndseed_CODE_64bit {
|
Line 5280 sub rndseed_CODE_64bit {
|
| } |
} |
| } |
} |
| |
|
| |
sub rndseed_CODE_64bit4 { |
| |
my ($symb,$courseid,$domain,$username)=@_; |
| |
{ |
| |
use integer; |
| |
my $symbchck=unpack("%32S*",$symb.' ') << 16; |
| |
my $symbseed=numval3($symb); |
| |
my $CODEchck=unpack("%32S*",&getCODE().' ') << 16; |
| |
my $CODEseed=numval3(&getCODE()); |
| |
my $courseseed=unpack("%32S*",$courseid.' '); |
| |
my $num1=$symbseed+$CODEchck; |
| |
my $num2=$CODEseed+$courseseed+$symbchck; |
| |
#&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck"); |
| |
#&Apache::lonxml::debug("rndseed :$num1:$num2:$symb"); |
| |
if ($_64bit) { $num1=(($num1<<32)>>32); } |
| |
if ($_64bit) { $num2=(($num2<<32)>>32); } |
| |
return "$num1:$num2"; |
| |
} |
| |
} |
| |
|
| sub setup_random_from_rndseed { |
sub setup_random_from_rndseed { |
| my ($rndseed)=@_; |
my ($rndseed)=@_; |
| if ($rndseed =~/([,:])/) { |
if ($rndseed =~/([,:])/) { |
|
Line 5330 sub current_machine_ids {
|
Line 5583 sub current_machine_ids {
|
| |
|
| sub declutter { |
sub declutter { |
| my $thisfn=shift; |
my $thisfn=shift; |
| |
if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); } |
| $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//; |
$thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//; |
| $thisfn=~s/^\///; |
$thisfn=~s/^\///; |
| $thisfn=~s/^res\///; |
$thisfn=~s/^res\///; |
|
Line 5383 sub thaw_unescape {
|
Line 5637 sub thaw_unescape {
|
| } |
} |
| |
|
| sub mod_perl_version { |
sub mod_perl_version { |
| |
return 1; |
| if (defined($perlvar{'MODPERL2'})) { |
if (defined($perlvar{'MODPERL2'})) { |
| return 2; |
return 2; |
| } |
} |
| return 1; |
|
| } |
} |
| |
|
| sub correct_line_ends { |
sub correct_line_ends { |
|
Line 5399 sub correct_line_ends {
|
Line 5653 sub correct_line_ends {
|
| sub goodbye { |
sub goodbye { |
| &logthis("Starting Shut down"); |
&logthis("Starting Shut down"); |
| #not converted to using infrastruture and probably shouldn't be |
#not converted to using infrastruture and probably shouldn't be |
| &logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache))); |
&logthis(sprintf("%-20s is %s",'%badServerCache',length(&freeze(\%badServerCache)))); |
| #converted |
#converted |
| &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache))); |
# &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache))); |
| &logthis(sprintf("%-20s is %s",'%homecache',scalar(%homecache))); |
# &logthis(sprintf("%-20s is %s",'%homecache',length(&freeze(\%homecache)))); |
| &logthis(sprintf("%-20s is %s",'%titlecache',scalar(%titlecache))); |
# &logthis(sprintf("%-20s is %s",'%titlecache',length(&freeze(\%titlecache)))); |
| &logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache))); |
# &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&freeze(\%courseresdatacache)))); |
| #1.1 only |
#1.1 only |
| &logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache))); |
# &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&freeze(\%userresdatacache)))); |
| &logthis(sprintf("%-20s is %s",'%getsectioncache',scalar(%getsectioncache))); |
# &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&freeze(\%getsectioncache)))); |
| &logthis(sprintf("%-20s is %s",'%courseresversioncache',scalar(%courseresversioncache))); |
# &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&freeze(\%courseresversioncache)))); |
| &logthis(sprintf("%-20s is %s",'%resversioncache',scalar(%resversioncache))); |
# &logthis(sprintf("%-20s is %s",'%resversioncache',length(&freeze(\%resversioncache)))); |
| |
&logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered)))); |
| |
&logthis(sprintf("%-20s is %s",'kicks',$kicks)); |
| |
&logthis(sprintf("%-20s is %s",'hits',$hits)); |
| &flushcourselogs(); |
&flushcourselogs(); |
| &logthis("Shutting down"); |
&logthis("Shutting down"); |
| return DONE; |
return DONE; |
|
Line 5419 BEGIN {
|
Line 5676 BEGIN {
|
| # ----------------------------------- Read loncapa.conf and loncapa_apache.conf |
# ----------------------------------- Read loncapa.conf and loncapa_apache.conf |
| unless ($readit) { |
unless ($readit) { |
| { |
{ |
| |
# FIXME: Use LONCAPA::Configuration::read_conf here and omit next block |
| open(my $config,"</etc/httpd/conf/loncapa.conf"); |
open(my $config,"</etc/httpd/conf/loncapa.conf"); |
| |
|
| while (my $configline=<$config>) { |
while (my $configline=<$config>) { |
|
Line 5554 BEGIN {
|
Line 5812 BEGIN {
|
| |
|
| } |
} |
| |
|
| %metacache=(); |
$memcache=new Cache::Memcached({'servers'=>['127.0.0.1:11211']}); |
| |
|
| $processmarker='_'.time.'_'.$perlvar{'lonHostID'}; |
$processmarker='_'.time.'_'.$perlvar{'lonHostID'}; |
| $dumpcount=0; |
$dumpcount=0; |
|
Line 5565 $readit=1;
|
Line 5823 $readit=1;
|
| { |
{ |
| use integer; |
use integer; |
| my $test=(2**32)+1; |
my $test=(2**32)+1; |
| if ($test != 0) { $_64bit=1; } |
if ($test != 0) { $_64bit=1; } else { $_64bit=0; } |
| &logthis(" Detected 64bit platform ($_64bit)"); |
&logthis(" Detected 64bit platform ($_64bit)"); |
| } |
} |
| } |
} |
|
Line 6054 returns the data handle
|
Line 6312 returns the data handle
|
| =item * |
=item * |
| |
|
| symbverify($symb,$thisfn) : verifies that $symb actually exists and is |
symbverify($symb,$thisfn) : verifies that $symb actually exists and is |
| a possible symb for the URL in $thisfn, returns a 1 on success, 0 on |
a possible symb for the URL in $thisfn, and if is an encryypted |
| failure, user must be in a course, as it assumes the existance of the |
resource that the user accessed using /enc/ returns a 1 on success, 0 |
| course initi hash, and uses $ENV('request.course.id'} |
on failure, user must be in a course, as it assumes the existance of |
| |
the course initial hash, and uses $ENV('request.course.id'} |
| |
|
| |
|
| =item * |
=item * |
![[BACK]](/icons/back.gif){kind=icon}
Return to lonnet.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / lonnet / perl