version 1.1056.4.33.2.2, 2012/02/08 01:05:20
|
version 1.1123, 2011/08/01 22:13:49
|
Line 76 use HTTP::Date;
|
Line 76 use HTTP::Date;
|
use Image::Magick; |
use Image::Magick; |
|
|
use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir |
use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir |
$_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease |
$_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease); |
%managerstab); |
|
|
|
my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash, |
my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash, |
%userrolehash, $processmarker, $dumpcount, %coursedombuf, |
%userrolehash, $processmarker, $dumpcount, %coursedombuf, |
Line 96 use Math::Random;
|
Line 95 use Math::Random;
|
use File::MMagic; |
use File::MMagic; |
use LONCAPA qw(:DEFAULT :match); |
use LONCAPA qw(:DEFAULT :match); |
use LONCAPA::Configuration; |
use LONCAPA::Configuration; |
|
|
use File::Copy; |
use File::Copy; |
|
|
my $readit; |
my $readit; |
Line 288 sub get_server_homeID {
|
Line 288 sub get_server_homeID {
|
} |
} |
my $cachetime = 12*3600; |
my $cachetime = 12*3600; |
my $serverhomeID; |
my $serverhomeID; |
if ($caller eq 'loncron') { |
if ($caller eq 'loncron') { |
my @machine_ids = &machine_ids($hostname); |
my @machine_ids = &machine_ids($hostname); |
foreach my $id (@machine_ids) { |
foreach my $id (@machine_ids) { |
my $response = &reply('serverhomeID',$id); |
my $response = &reply('serverhomeID',$id); |
Line 306 sub get_server_homeID {
|
Line 306 sub get_server_homeID {
|
return &do_cache_new('serverhomeID',$hostname,$serverhomeID,$cachetime); |
return &do_cache_new('serverhomeID',$hostname,$serverhomeID,$cachetime); |
} |
} |
|
|
|
sub get_remote_globals { |
|
my ($lonhost,$whathash,$ignore_cache) = @_; |
|
my (%returnhash,%whatneeded); |
|
if (ref($whathash) eq 'ARRAY') { |
|
foreach my $what (sort(keys(%{$whathash}))) { |
|
my $type = $whathash->{$what}; |
|
my $hashid = $lonhost.'-'.$what; |
|
my ($result,$cached); |
|
unless ($ignore_cache) { |
|
($result,$cached)=&is_cached_new('lonnetglobal',$hashid); |
|
$returnhash{$what} = $result; |
|
} |
|
if (defined($cached)) { |
|
$returnhash{$what} = $result; |
|
} else { |
|
$whatneeded{$what} = $type; |
|
} |
|
} |
|
if (keys(%whatneeded) > 0) { |
|
my $requested = &freeze_escape(\%whatneeded); |
|
my $rep=&reply('readlonnetglobal:'.$requested,$lonhost); |
|
unless (($rep=~/^refused/) || ($rep=~/^rejected/) || ($rep eq 'con_lost')) { |
|
my @pairs=split(/\&/,$rep); |
|
if ($rep !~ /^error/) { |
|
foreach my $item (@pairs) { |
|
my ($key,$value)=split(/=/,$item,2); |
|
my $what = &unescape($key); |
|
my $hashid = $lonhost.'-'.$what; |
|
$returnhash{$what}=&thaw_unescape($value); |
|
&do_cache_new('lonnetglobal',$hashid,$returnhash{$what},600); |
|
} |
|
} |
|
} |
|
} |
|
} |
|
return %returnhash; |
|
} |
|
|
# -------------------------------------------------- Non-critical communication |
# -------------------------------------------------- Non-critical communication |
sub subreply { |
sub subreply { |
my ($cmd,$server)=@_; |
my ($cmd,$server)=@_; |
Line 758 sub userload {
|
Line 796 sub userload {
|
return $userloadpercent; |
return $userloadpercent; |
} |
} |
|
|
# ------------------------------------------ Fight off request when overloaded |
|
|
|
sub overloaderror { |
|
my ($r,$checkserver)=@_; |
|
unless ($checkserver) { $checkserver=$perlvar{'lonHostID'}; } |
|
my $loadavg; |
|
if ($checkserver eq $perlvar{'lonHostID'}) { |
|
open(my $loadfile,'/proc/loadavg'); |
|
$loadavg=<$loadfile>; |
|
$loadavg =~ s/\s.*//g; |
|
$loadavg = 100*$loadavg/$perlvar{'lonLoadLim'}; |
|
close($loadfile); |
|
} else { |
|
$loadavg=&reply('load',$checkserver); |
|
} |
|
my $overload=$loadavg-100; |
|
if ($overload>0) { |
|
$r->err_headers_out->{'Retry-After'}=$overload; |
|
$r->log_error('Overload of '.$overload.' on '.$checkserver); |
|
return 413; |
|
} |
|
return ''; |
|
} |
|
|
|
# ------------------------------ Find server with least workload from spare.tab |
# ------------------------------ Find server with least workload from spare.tab |
|
|
sub spareserver { |
sub spareserver { |
Line 797 sub spareserver {
|
Line 811 sub spareserver {
|
my %udomdefaults = &Apache::lonnet::get_domain_defaults($udom); |
my %udomdefaults = &Apache::lonnet::get_domain_defaults($udom); |
$remotesessions = $udomdefaults{'remotesessions'}; |
$remotesessions = $udomdefaults{'remotesessions'}; |
} |
} |
foreach my $try_server (@{ $spareid{'primary'} }) { |
my $spareshash = &this_host_spares($udom); |
if ($uint_dom) { |
if (ref($spareshash) eq 'HASH') { |
next unless (&spare_can_host($udom,$uint_dom,$remotesessions, |
if (ref($spareshash->{'primary'}) eq 'ARRAY') { |
$try_server)); |
foreach my $try_server (@{ $spareshash->{'primary'} }) { |
|
if ($uint_dom) { |
|
next unless (&spare_can_host($udom,$uint_dom,$remotesessions, |
|
$try_server)); |
|
} |
|
($spare_server, $lowest_load) = |
|
&compare_server_load($try_server, $spare_server, $lowest_load); |
|
} |
} |
} |
($spare_server, $lowest_load) = |
|
&compare_server_load($try_server, $spare_server, $lowest_load); |
|
} |
|
|
|
my $found_server = ($spare_server ne '' && $lowest_load < 100); |
my $found_server = ($spare_server ne '' && $lowest_load < 100); |
|
|
if (!$found_server) { |
if (!$found_server) { |
foreach my $try_server (@{ $spareid{'default'} }) { |
if (ref($spareshash->{'default'}) eq 'ARRAY') { |
if ($uint_dom) { |
foreach my $try_server (@{ $spareshash->{'default'} }) { |
next unless (&spare_can_host($udom,$uint_dom,$remotesessions, |
if ($uint_dom) { |
$try_server)); |
next unless (&spare_can_host($udom,$uint_dom, |
} |
$remotesessions,$try_server)); |
($spare_server, $lowest_load) = |
} |
&compare_server_load($try_server, $spare_server, $lowest_load); |
($spare_server, $lowest_load) = |
} |
&compare_server_load($try_server, $spare_server, $lowest_load); |
|
} |
|
} |
|
} |
} |
} |
|
|
if (!$want_server_name) { |
if (!$want_server_name) { |
Line 841 sub compare_server_load {
|
Line 862 sub compare_server_load {
|
my $userloadans = &reply('userload',$try_server); |
my $userloadans = &reply('userload',$try_server); |
|
|
if ($loadans !~ /\d/ && $userloadans !~ /\d/) { |
if ($loadans !~ /\d/ && $userloadans !~ /\d/) { |
return ($spare_server, $lowest_load); #didn't get a number from the server |
return ($spare_server, $lowest_load); #didn't get a number from the server |
} |
} |
|
|
my $load; |
my $load; |
Line 867 sub compare_server_load {
|
Line 888 sub compare_server_load {
|
# --------------------------- ask offload servers if user already has a session |
# --------------------------- ask offload servers if user already has a session |
sub find_existing_session { |
sub find_existing_session { |
my ($udom,$uname) = @_; |
my ($udom,$uname) = @_; |
foreach my $try_server (@{ $spareid{'primary'} }, |
my $spareshash = &this_host_spares($udom); |
@{ $spareid{'default'} }) { |
if (ref($spareshash) eq 'HASH') { |
return $try_server if (&has_user_session($try_server, $udom, $uname)); |
if (ref($spareshash->{'primary'}) eq 'ARRAY') { |
|
foreach my $try_server (@{ $spareshash->{'primary'} }) { |
|
return $try_server if (&has_user_session($try_server, $udom, $uname)); |
|
} |
|
} |
|
if (ref($spareshash->{'default'}) eq 'ARRAY') { |
|
foreach my $try_server (@{ $spareshash->{'default'} }) { |
|
return $try_server if (&has_user_session($try_server, $udom, $uname)); |
|
} |
|
} |
} |
} |
return; |
return; |
} |
} |
Line 891 sub choose_server {
|
Line 921 sub choose_server {
|
my %domconfhash = &Apache::loncommon::get_domainconf($udom); |
my %domconfhash = &Apache::loncommon::get_domainconf($udom); |
my %servers = &get_servers($udom); |
my %servers = &get_servers($udom); |
my $lowest_load = 30000; |
my $lowest_load = 30000; |
my ($login_host,$hostname,$portal_path,$isredirect); |
my ($login_host,$hostname,$portal_path); |
foreach my $lonhost (keys(%servers)) { |
foreach my $lonhost (keys(%servers)) { |
my $loginvia; |
my $loginvia; |
if ($checkloginvia) { |
if ($checkloginvia) { |
Line 899 sub choose_server {
|
Line 929 sub choose_server {
|
if ($loginvia) { |
if ($loginvia) { |
my ($server,$path) = split(/:/,$loginvia); |
my ($server,$path) = split(/:/,$loginvia); |
($login_host, $lowest_load) = |
($login_host, $lowest_load) = |
&compare_server_load($lonhost, $login_host, $lowest_load); |
&compare_server_load($server, $login_host, $lowest_load); |
if ($login_host eq $server) { |
if ($login_host eq $server) { |
$portal_path = $path; |
$portal_path = $path; |
$isredirect = 1; |
|
} |
} |
} else { |
} else { |
($login_host, $lowest_load) = |
($login_host, $lowest_load) = |
&compare_server_load($lonhost, $login_host, $lowest_load); |
&compare_server_load($lonhost, $login_host, $lowest_load); |
if ($login_host eq $lonhost) { |
if ($login_host eq $lonhost) { |
$portal_path = ''; |
$portal_path = ''; |
$isredirect = ''; |
|
} |
} |
} |
} |
} else { |
} else { |
Line 920 sub choose_server {
|
Line 948 sub choose_server {
|
if ($login_host ne '') { |
if ($login_host ne '') { |
$hostname = &hostname($login_host); |
$hostname = &hostname($login_host); |
} |
} |
return ($login_host,$hostname,$portal_path,$isredirect); |
return ($login_host,$hostname,$portal_path); |
} |
} |
|
|
# --------------------------------------------- Try to change a user's password |
# --------------------------------------------- Try to change a user's password |
Line 1104 sub spare_can_host {
|
Line 1132 sub spare_can_host {
|
return $canhost; |
return $canhost; |
} |
} |
|
|
|
sub this_host_spares { |
|
my ($dom) = @_; |
|
my $cachetime = 60*60*24; |
|
my @hosts = ¤t_machine_ids(); |
|
foreach my $lonhost (@hosts) { |
|
if (&host_domain($lonhost) eq $dom) { |
|
my ($result,$cached)=&is_cached_new('spares',$dom); |
|
if (defined($cached)) { |
|
return $result; |
|
} else { |
|
my %domconfig = |
|
&Apache::lonnet::get_dom('configuration',['usersessions'],$dom); |
|
if (ref($domconfig{'usersessions'}) eq 'HASH') { |
|
if (ref($domconfig{'usersessions'}{'spares'}) eq 'HASH') { |
|
if (ref($domconfig{'usersessions'}{'spares'}{$lonhost}) eq 'HASH') { |
|
return &do_cache_new('spares',$dom,$domconfig{'usersessions'}{'spares'}{$lonhost},$cachetime); |
|
} |
|
} |
|
} |
|
} |
|
last; |
|
} |
|
} |
|
my $serverhomedom = &host_domain($perlvar{'lonHostID'}); |
|
my ($result,$cached)=&is_cached_new('spares',$serverhomedom); |
|
if (defined($cached)) { |
|
return $result; |
|
} else { |
|
my %homedomconfig = |
|
&Apache::lonnet::get_dom('configuration',['usersessions'],$serverhomedom); |
|
if (ref($homedomconfig{'usersessions'}) eq 'HASH') { |
|
if (ref($homedomconfig{'usersessions'}{'spares'}) eq 'HASH') { |
|
if (ref($homedomconfig{'usersessions'}{'spares'}{$perlvar{'lonHostID'}}) eq 'HASH') { |
|
return &do_cache_new('spares',$serverhomedom,$homedomconfig{'usersessions'}{'spares'}{$perlvar{'lonHostID'}},$cachetime); |
|
} |
|
} |
|
} |
|
} |
|
return \%spareid; |
|
} |
|
|
# ---------------------- Find the homebase for a user from domain's lib servers |
# ---------------------- Find the homebase for a user from domain's lib servers |
|
|
my %homecache; |
my %homecache; |
Line 1587 sub get_domain_defaults {
|
Line 1656 sub get_domain_defaults {
|
$domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'}; |
$domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'}; |
$domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'}; |
$domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'}; |
$domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'}; |
$domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'}; |
$domdefaults{'portal_def'} = $domconfig{'defaults'}{'portal_def'}; |
|
} else { |
} else { |
$domdefaults{'lang_def'} = &domain($domain,'lang_def'); |
$domdefaults{'lang_def'} = &domain($domain,'lang_def'); |
$domdefaults{'auth_def'} = &domain($domain,'auth_def'); |
$domdefaults{'auth_def'} = &domain($domain,'auth_def'); |
Line 2047 sub getversion {
|
Line 2115 sub getversion {
|
|
|
sub currentversion { |
sub currentversion { |
my $fname=shift; |
my $fname=shift; |
my ($result,$cached)=&is_cached_new('resversion',$fname); |
|
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/; |
my ($udom,$uname)=split(/\//,$author); |
my ($udom,$uname)=split(/\//,$author); |
my $home=homeserver($uname,$udom); |
my $home=&homeserver($uname,$udom); |
if ($home eq 'no_host') { |
if ($home eq 'no_host') { |
return -1; |
return -1; |
} |
} |
my $answer=reply("currentversion:$fname",$home); |
my $answer=&reply("currentversion:$fname",$home); |
if (($answer eq 'con_lost') || ($answer eq 'rejected')) { |
if (($answer eq 'con_lost') || ($answer eq 'rejected')) { |
return -1; |
return -1; |
} |
} |
return &do_cache_new('resversion',$fname,$answer,600); |
return $answer; |
|
} |
|
|
|
# |
|
# Return special version number of resource if set by override, empty otherwise |
|
# |
|
sub usedversion { |
|
my $fname=shift; |
|
unless ($fname) { $fname=$env{'request.uri'}; } |
|
my ($urlversion)=($fname=~/\.(\d+)\.\w+$/); |
|
if ($urlversion) { return $urlversion; } |
|
return ''; |
} |
} |
|
|
# ----------------------------- Subscribe to a resource, return URL if possible |
# ----------------------------- Subscribe to a resource, return URL if possible |
Line 2322 sub process_coursefile {
|
Line 2399 sub process_coursefile {
|
} |
} |
if (ref($mimetype)) { |
if (ref($mimetype)) { |
$$mimetype = $type; |
$$mimetype = $type; |
} |
} |
} |
} |
$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, |
$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, |
$home); |
$home); |
Line 2440 sub resizeImage {
|
Line 2517 sub resizeImage {
|
# input: $formname - the contents of the file are in $env{"form.$formname"} |
# input: $formname - the contents of the file are in $env{"form.$formname"} |
# the desired filename is in $env{"form.$formname.filename"} |
# the desired filename is in $env{"form.$formname.filename"} |
# $context - possible values: coursedoc, existingfile, overwrite, |
# $context - possible values: coursedoc, existingfile, overwrite, |
# canceloverwrite, or ''. |
# canceloverwrite, or ''. |
# if 'coursedoc': upload to the current course |
# if 'coursedoc': upload to the current course |
# if 'existingfile': write file to tmp/overwrites directory |
# if 'existingfile': write file to tmp/overwrites directory |
# if 'canceloverwrite': delete file written to tmp/overwrites directory |
# if 'canceloverwrite': delete file written to tmp/overwrites directory |
# $context is passed as argument to &finishuserfileupload |
# $context is passed as argument to &finishuserfileupload |
# $subdir - directory in userfile to store the file into |
# $subdir - directory in userfile to store the file into |
# $parser - instruction to parse file for objects ($parser = parse) |
# $parser - instruction to parse file for objects ($parser = parse) |
# $allfiles - reference to hash for embedded objects |
# $allfiles - reference to hash for embedded objects |
Line 2596 sub finishuserfileupload {
|
Line 2673 sub finishuserfileupload {
|
return '/adm/notfound.html'; |
return '/adm/notfound.html'; |
} |
} |
if ($context eq 'overwrite') { |
if ($context eq 'overwrite') { |
my $source = $perlvar{'lonDaemons'}.'/tmp/overwrites/'.$docudom.'/'.$docuname.'/'.$fname; |
my $source = LONCAPA::tempdir().'/overwrites/'.$docudom.'/'.$docuname.'/'.$fname; |
my $target = $filepath.'/'.$file; |
my $target = $filepath.'/'.$file; |
if (-e $source) { |
if (-e $source) { |
my @info = stat($source); |
my @info = stat($source); |
if ($info[9] eq $env{'form.timestamp'}) { |
if ($info[9] eq $env{'form.timestamp'}) { |
unless (&File::Copy::move($source,$target)) { |
unless (&File::Copy::move($source,$target)) { |
&logthis('Failed to overwrite '.$filepath.'/'.$file); |
&logthis('Failed to overwrite '.$filepath.'/'.$file); |
return "Moving from $source failed"; |
return "Moving from $source failed"; |
Line 2611 sub finishuserfileupload {
|
Line 2688 sub finishuserfileupload {
|
} else { |
} else { |
return "Temporary file: $source missing"; |
return "Temporary file: $source missing"; |
} |
} |
} elsif (!print FH ($env{'form.'.$formname})) { |
} elsif (!print FH ($env{'form.'.$formname})) { |
&logthis('Failed to write to '.$filepath.'/'.$file); |
&logthis('Failed to write to '.$filepath.'/'.$file); |
print STDERR ('Failed to write to '.$filepath.'/'.$file."\n"); |
print STDERR ('Failed to write to '.$filepath.'/'.$file."\n"); |
return '/adm/notfound.html'; |
return '/adm/notfound.html'; |
Line 3172 sub get_my_roles {
|
Line 3249 sub get_my_roles {
|
unless (defined($uname)) { $uname=$env{'user.name'}; } |
unless (defined($uname)) { $uname=$env{'user.name'}; } |
unless (defined($udom)) { $udom=$env{'user.domain'}; } |
unless (defined($udom)) { $udom=$env{'user.domain'}; } |
my (%dumphash,%nothide); |
my (%dumphash,%nothide); |
if ($context eq 'userroles') { |
if ($context eq 'userroles') { |
my $extra = &freeze_escape({'skipcheck' => 1}); |
my $extra = &freeze_escape({'skipcheck' => 1}); |
%dumphash = &dump('roles',$udom,$uname,'.',undef,$extra); |
%dumphash = &dump('roles',$udom,$uname,'.',undef,$extra); |
} else { |
} else { |
Line 3506 sub get_domain_roles {
|
Line 3583 sub get_domain_roles {
|
return %personnel; |
return %personnel; |
} |
} |
|
|
# ----------------------------------------------------------- Check out an item |
# ----------------------------------------------------------- Interval timing |
|
|
sub get_first_access { |
sub get_first_access { |
my ($type,$argsymb)=@_; |
my ($type,$argsymb)=@_; |
Line 3542 sub set_first_access {
|
Line 3619 sub set_first_access {
|
return 'already_set'; |
return 'already_set'; |
} |
} |
|
|
sub checkout { |
|
my ($symb,$tuname,$tudom,$tcrsid)=@_; |
|
my $now=time; |
|
my $lonhost=$perlvar{'lonHostID'}; |
|
my $infostr=&escape( |
|
'CHECKOUTTOKEN&'. |
|
$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=('resource.0.outtoken' => $token, |
|
'resource.0.checkouttime' => $now, |
|
'resource.0.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.'_'.&hostname($lonhost).'_'.$tb; |
|
$dtoken=~s/\W/\_/g; |
|
my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)= |
|
split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost))); |
|
|
|
unless (($tuname) && ($tudom)) { |
|
&logthis('Check in '.$token.' ('.$dtoken.') failed'); |
|
return ''; |
|
} |
|
|
|
unless (&allowed('mgr',$tcrsid)) { |
|
&logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '. |
|
$env{'user.name'}.' - '.$env{'user.domain'}); |
|
return ''; |
|
} |
|
|
|
my %infohash=('resource.0.intoken' => $token, |
|
'resource.0.checkintime' => $now, |
|
'resource.0.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 3731 sub hashref2str {
|
Line 3723 sub hashref2str {
|
$result.='='; |
$result.='='; |
#print("Got a ref of ".(ref($key))." skipping."); |
#print("Got a ref of ".(ref($key))." skipping."); |
} else { |
} else { |
if (defined($key)) {$result.=&escape($key).'=';} else { last; } |
if ($key) {$result.=&escape($key).'=';} else { last; } |
} |
} |
|
|
if(ref($hashref->{$key}) eq 'ARRAY') { |
if(ref($hashref->{$key}) eq 'ARRAY') { |
Line 3883 sub tmpreset {
|
Line 3875 sub tmpreset {
|
if ($domain eq 'public' && $stuname eq 'public') { |
if ($domain eq 'public' && $stuname eq 'public') { |
$stuname=$ENV{'REMOTE_ADDR'}; |
$stuname=$ENV{'REMOTE_ADDR'}; |
} |
} |
my $path=$perlvar{'lonDaemons'}.'/tmp'; |
my $path=LONCAPA::tempdir(); |
my %hash; |
my %hash; |
if (tie(%hash,'GDBM_File', |
if (tie(%hash,'GDBM_File', |
$path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', |
$path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', |
Line 3922 sub tmpstore {
|
Line 3914 sub tmpstore {
|
} |
} |
my $now=time; |
my $now=time; |
my %hash; |
my %hash; |
my $path=$perlvar{'lonDaemons'}.'/tmp'; |
my $path=LONCAPA::tempdir(); |
if (tie(%hash,'GDBM_File', |
if (tie(%hash,'GDBM_File', |
$path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', |
$path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', |
&GDBM_WRCREAT(),0640)) { |
&GDBM_WRCREAT(),0640)) { |
Line 3968 sub tmprestore {
|
Line 3960 sub tmprestore {
|
$namespace=~s/\//\_/g; |
$namespace=~s/\//\_/g; |
$namespace=~s/\W//g; |
$namespace=~s/\W//g; |
my %hash; |
my %hash; |
my $path=$perlvar{'lonDaemons'}.'/tmp'; |
my $path=LONCAPA::tempdir(); |
if (tie(%hash,'GDBM_File', |
if (tie(%hash,'GDBM_File', |
$path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', |
$path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', |
&GDBM_READER(),0640)) { |
&GDBM_READER(),0640)) { |
Line 4105 sub restore {
|
Line 4097 sub restore {
|
} |
} |
|
|
# ---------------------------------------------------------- Course Description |
# ---------------------------------------------------------- Course Description |
|
# |
|
# |
|
|
sub coursedescription { |
sub coursedescription { |
my ($courseid,$args)=@_; |
my ($courseid,$args)=@_; |
Line 4134 sub coursedescription {
|
Line 4128 sub coursedescription {
|
return %returnhash; |
return %returnhash; |
} |
} |
|
|
# get the data agin |
# get the data again |
|
|
if (!$args->{'one_time'}) { |
if (!$args->{'one_time'}) { |
$envhash{'course.'.$normalid.'.last_cache'}=time; |
$envhash{'course.'.$normalid.'.last_cache'}=time; |
} |
} |
Line 4142 sub coursedescription {
|
Line 4137 sub coursedescription {
|
if ($chome ne 'no_host') { |
if ($chome ne 'no_host') { |
%returnhash=&dump('environment',$cdomain,$cnum); |
%returnhash=&dump('environment',$cdomain,$cnum); |
if (!exists($returnhash{'con_lost'})) { |
if (!exists($returnhash{'con_lost'})) { |
|
my $username = $env{'user.name'}; # Defult username |
|
if(defined $args->{'user'}) { |
|
$username = $args->{'user'}; |
|
} |
$returnhash{'home'}= $chome; |
$returnhash{'home'}= $chome; |
$returnhash{'domain'} = $cdomain; |
$returnhash{'domain'} = $cdomain; |
$returnhash{'num'} = $cnum; |
$returnhash{'num'} = $cnum; |
Line 4152 sub coursedescription {
|
Line 4151 sub coursedescription {
|
$envhash{'course.'.$normalid.'.'.$name}=$value; |
$envhash{'course.'.$normalid.'.'.$name}=$value; |
} |
} |
$returnhash{'url'}=&clutter($returnhash{'url'}); |
$returnhash{'url'}=&clutter($returnhash{'url'}); |
$returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'. |
$returnhash{'fn'}=LONCAPA::tempdir() . |
$env{'user.name'}.'_'.$cdomain.'_'.$cnum; |
$username.'_'.$cdomain.'_'.$cnum; |
$envhash{'course.'.$normalid.'.home'}=$chome; |
$envhash{'course.'.$normalid.'.home'}=$chome; |
$envhash{'course.'.$normalid.'.domain'}=$cdomain; |
$envhash{'course.'.$normalid.'.domain'}=$cdomain; |
$envhash{'course.'.$normalid.'.num'}=$cnum; |
$envhash{'course.'.$normalid.'.num'}=$cnum; |
Line 4371 sub set_userprivs {
|
Line 4370 sub set_userprivs {
|
my $adv=0; |
my $adv=0; |
my %grouproles = (); |
my %grouproles = (); |
if (keys(%{$allgroups}) > 0) { |
if (keys(%{$allgroups}) > 0) { |
my @groupkeys; |
my @groupkeys; |
foreach my $role (keys(%{$allroles})) { |
foreach my $role (keys(%{$allroles})) { |
push(@groupkeys,$role); |
push(@groupkeys,$role); |
} |
} |
Line 4447 sub role_status {
|
Line 4446 sub role_status {
|
my %userroles = ( |
my %userroles = ( |
'user.role.'.$$role.'.'.$$where => $$tstart.'.'.$$tend |
'user.role.'.$$role.'.'.$$where => $$tstart.'.'.$$tend |
); |
); |
@rolecodes = ('cm'); |
@rolecodes = ('cm'); |
my $spec=$$role.'.'.$$where; |
my $spec=$$role.'.'.$$where; |
my ($tdummy,$tdomain,$trest)=split(/\//,$$where); |
my ($tdummy,$tdomain,$trest)=split(/\//,$$where); |
if ($$role =~ /^cr\//) { |
if ($$role =~ /^cr\//) { |
Line 4490 sub role_status {
|
Line 4489 sub role_status {
|
|
|
sub get_groups_roles { |
sub get_groups_roles { |
my ($cdom,$rest,$cdom_courseroles,$rolecodes,$groups_roles) = @_; |
my ($cdom,$rest,$cdom_courseroles,$rolecodes,$groups_roles) = @_; |
return unless((ref($cdom_courseroles) eq 'HASH') && |
return unless((ref($cdom_courseroles) eq 'HASH') && |
(ref($rolecodes) eq 'ARRAY') && |
(ref($rolecodes) eq 'ARRAY') && |
(ref($groups_roles) eq 'HASH')); |
(ref($groups_roles) eq 'HASH')); |
if (keys(%{$cdom_courseroles}) > 0) { |
if (keys(%{$cdom_courseroles}) > 0) { |
my ($cnum) = ($rest =~ /^($match_courseid)/); |
my ($cnum) = ($rest =~ /^($match_courseid)/); |
if ($cdom ne '' && $cnum ne '') { |
if ($cdom ne '' && $cnum ne '') { |
Line 4642 sub dump {
|
Line 4641 sub dump {
|
my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range:$extra",$uhome); |
my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range:$extra",$uhome); |
my @pairs=split(/\&/,$rep); |
my @pairs=split(/\&/,$rep); |
my %returnhash=(); |
my %returnhash=(); |
foreach my $item (@pairs) { |
if (!($rep =~ /^error/ )) { |
my ($key,$value)=split(/=/,$item,2); |
foreach my $item (@pairs) { |
$key = &unescape($key); |
my ($key,$value)=split(/=/,$item,2); |
next if ($key =~ /^error: 2 /); |
$key = &unescape($key); |
$returnhash{$key}=&thaw_unescape($value); |
next if ($key =~ /^error: 2 /); |
|
$returnhash{$key}=&thaw_unescape($value); |
|
} |
} |
} |
return %returnhash; |
return %returnhash; |
} |
} |
|
|
|
|
# --------------------------------------------------------- dumpstore interface |
# --------------------------------------------------------- dumpstore interface |
|
|
sub dumpstore { |
sub dumpstore { |
Line 4933 sub tmpget {
|
Line 4935 sub tmpget {
|
return %returnhash; |
return %returnhash; |
} |
} |
|
|
# ------------------------------------------------------------ tmpget interface |
# ------------------------------------------------------------ tmpdel interface |
sub tmpdel { |
sub tmpdel { |
my ($token,$server)=@_; |
my ($token,$server)=@_; |
if (!defined($server)) { $server = $perlvar{'lonHostID'}; } |
if (!defined($server)) { $server = $perlvar{'lonHostID'}; } |
Line 5184 sub is_portfolio_file {
|
Line 5186 sub is_portfolio_file {
|
} |
} |
|
|
sub usertools_access { |
sub usertools_access { |
my ($uname,$udom,$tool,$action,$context,$userenvref,$domdefref,$is_advref) = @_; |
my ($uname,$udom,$tool,$action,$context,$userenvref,$domdefref,$is_advref)=@_; |
my ($access,%tools); |
my ($access,%tools); |
if ($context eq '') { |
if ($context eq '') { |
$context = 'tools'; |
$context = 'tools'; |
Line 5331 sub is_advanced_user {
|
Line 5333 sub is_advanced_user {
|
my ($udom,$uname) = @_; |
my ($udom,$uname) = @_; |
if ($udom ne '' && $uname ne '') { |
if ($udom ne '' && $uname ne '') { |
if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { |
if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { |
return $env{'user.adv'}; |
return $env{'user.adv'}; |
} |
} |
} |
} |
my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1); |
my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1); |
Line 5849 sub allowed {
|
Line 5851 sub allowed {
|
my $unamedom=$env{'user.name'}.':'.$env{'user.domain'}; |
my $unamedom=$env{'user.name'}.':'.$env{'user.domain'}; |
if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'} |
if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'} |
=~/\Q$rolecode\E/) { |
=~/\Q$rolecode\E/) { |
if (($priv ne 'pch') && ($priv ne 'plc')) { |
if (($priv ne 'pch') && ($priv ne 'plc')) { |
&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'. |
&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'. |
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '. |
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '. |
$env{'request.course.id'}); |
$env{'request.course.id'}); |
Line 5859 sub allowed {
|
Line 5861 sub allowed {
|
|
|
if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'} |
if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'} |
=~/\Q$unamedom\E/) { |
=~/\Q$unamedom\E/) { |
if (($priv ne 'pch') && ($priv ne 'plc')) { |
if (($priv ne 'pch') && ($priv ne 'plc')) { |
&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}. |
&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}. |
'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '. |
'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '. |
$env{'request.course.id'}); |
$env{'request.course.id'}); |
Line 5873 sub allowed {
|
Line 5875 sub allowed {
|
if ($thisallowed=~/R/) { |
if ($thisallowed=~/R/) { |
my $rolecode=(split(/\./,$env{'request.role'}))[0]; |
my $rolecode=(split(/\./,$env{'request.role'}))[0]; |
if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) { |
if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) { |
if (($priv ne 'pch') && ($priv ne 'plc')) { |
if (($priv ne 'pch') && ($priv ne 'plc')) { |
&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'. |
&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'. |
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode); |
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode); |
} |
} |
Line 6100 sub fetch_enrollment_query {
|
Line 6102 sub fetch_enrollment_query {
|
$$replyref{$key} = $value; |
$$replyref{$key} = $value; |
} |
} |
} else { |
} else { |
my $pathname = $perlvar{'lonDaemons'}.'/tmp'; |
my $pathname = LONCAPA::tempdir(); |
foreach my $line (@responses) { |
foreach my $line (@responses) { |
my ($key,$value) = split(/=/,$line); |
my ($key,$value) = split(/=/,$line); |
$$replyref{$key} = $value; |
$$replyref{$key} = $value; |
Line 6130 sub fetch_enrollment_query {
|
Line 6132 sub fetch_enrollment_query {
|
|
|
sub get_query_reply { |
sub get_query_reply { |
my $queryid=shift; |
my $queryid=shift; |
my $replyfile=$perlvar{'lonDaemons'}.'/tmp/'.$queryid; |
my $replyfile=LONCAPA::tempdir().$queryid; |
my $reply=''; |
my $reply=''; |
for (1..100) { |
for (1..100) { |
sleep 2; |
sleep 2; |
Line 6800 sub assignrole {
|
Line 6802 sub assignrole {
|
return 'refused'; |
return 'refused'; |
} |
} |
} |
} |
} elsif ($role eq 'au') { |
|
if ($url ne '/'.$udom.'/') { |
|
&logthis('Attempt by '.$env{'user.name'}.':'.$env{'user.domain'}. |
|
' to assign author role for '.$uname.':'.$udom. |
|
' in domain: '.$url.' refused (wrong domain).'); |
|
return 'refused'; |
|
} |
|
} |
} |
$mrole=$role; |
$mrole=$role; |
} |
} |
Line 6981 sub modifyuser {
|
Line 6976 sub modifyuser {
|
} |
} |
&logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. |
&logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. |
$umode.', '.$first.', '.$middle.', '. |
$umode.', '.$first.', '.$middle.', '. |
$last.', '.$gene.'(forceid: '.$forceid.'; candelete: '.$showcandelete.')'. |
$last.', '.$gene.'(forceid: '.$forceid.'; candelete: '.$showcandelete.')'. |
(defined($desiredhome) ? ' desiredhome = '.$desiredhome : |
(defined($desiredhome) ? ' desiredhome = '.$desiredhome : |
' desiredhome not specified'). |
' desiredhome not specified'). |
' by '.$env{'user.name'}.' at '.$env{'user.domain'}. |
' by '.$env{'user.name'}.' at '.$env{'user.domain'}. |
Line 7127 sub modifyuser {
|
Line 7122 sub modifyuser {
|
return 'ok'; |
return 'ok'; |
} |
} |
my $reply = &put('environment', \%names, $udom,$uname); |
my $reply = &put('environment', \%names, $udom,$uname); |
if ($reply ne 'ok') { |
if ($reply ne 'ok') { |
return 'error: '.$reply; |
return 'error: '.$reply; |
} |
} |
if ($names{'permanentemail'} ne $oldnames{'permanentemail'}) { |
if ($names{'permanentemail'} ne $oldnames{'permanentemail'}) { |
Line 7509 sub is_locked {
|
Line 7504 sub is_locked {
|
my ($file_name, $domain, $user, $which) = @_; |
my ($file_name, $domain, $user, $which) = @_; |
my @check; |
my @check; |
my $is_locked; |
my $is_locked; |
push(@check,$file_name); |
push (@check,$file_name); |
my %locked = &get('file_permissions',\@check, |
my %locked = &get('file_permissions',\@check, |
$env{'user.domain'},$env{'user.name'}); |
$env{'user.domain'},$env{'user.name'}); |
my ($tmp)=keys(%locked); |
my ($tmp)=keys(%locked); |
Line 7574 sub save_selected_files {
|
Line 7569 sub save_selected_files {
|
sub clear_selected_files { |
sub clear_selected_files { |
my ($user) = @_; |
my ($user) = @_; |
my $filename = $user."savedfiles"; |
my $filename = $user."savedfiles"; |
open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); |
open (OUT, '>'.LONCAPA::tempdir().$filename); |
print (OUT undef); |
print (OUT undef); |
close (OUT); |
close (OUT); |
return ("ok"); |
return ("ok"); |
Line 7584 sub files_in_path {
|
Line 7579 sub files_in_path {
|
my ($user, $path) = @_; |
my ($user, $path) = @_; |
my $filename = $user."savedfiles"; |
my $filename = $user."savedfiles"; |
my %return_files; |
my %return_files; |
open (IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); |
open (IN, '<'.LONCAPA::tempdir().$filename); |
while (my $line_in = <IN>) { |
while (my $line_in = <IN>) { |
chomp ($line_in); |
chomp ($line_in); |
my @paths_and_file = split (m!/!, $line_in); |
my @paths_and_file = split (m!/!, $line_in); |
Line 7606 sub files_not_in_path {
|
Line 7601 sub files_not_in_path {
|
my $filename = $user."savedfiles"; |
my $filename = $user."savedfiles"; |
my @return_files; |
my @return_files; |
my $path_part; |
my $path_part; |
open(IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); |
open(IN, '<'.LONCAPA::.$filename); |
while (my $line = <IN>) { |
while (my $line = <IN>) { |
#ok, I know it's clunky, but I want it to work |
#ok, I know it's clunky, but I want it to work |
my @paths_and_file = split(m|/|, $line); |
my @paths_and_file = split(m|/|, $line); |
Line 8673 sub add_prefix_and_part {
|
Line 8668 sub add_prefix_and_part {
|
# ---------------------------------------------------------------- Get metadata |
# ---------------------------------------------------------------- Get metadata |
|
|
my %metaentry; |
my %metaentry; |
|
my %importedpartids; |
sub metadata { |
sub metadata { |
my ($uri,$what,$liburi,$prefix,$depthcount)=@_; |
my ($uri,$what,$liburi,$prefix,$depthcount)=@_; |
$uri=&declutter($uri); |
$uri=&declutter($uri); |
Line 8699 sub metadata {
|
Line 8695 sub metadata {
|
if (defined($cached)) { return $result->{':'.$what}; } |
if (defined($cached)) { return $result->{':'.$what}; } |
} |
} |
{ |
{ |
|
# Imported parts would go here |
|
my %importedids=(); |
|
my @origfileimportpartids=(); |
|
my $importedparts=0; |
# |
# |
# Is this a recursive call for a library? |
# Is this a recursive call for a library? |
# |
# |
Line 8783 sub metadata {
|
Line 8783 sub metadata {
|
# This is not a package - some other kind of start tag |
# This is not a package - some other kind of start tag |
# |
# |
my $entry=$token->[1]; |
my $entry=$token->[1]; |
my $unikey; |
my $unikey=''; |
if ($entry eq 'import') { |
|
$unikey=''; |
|
} else { |
|
$unikey=$entry; |
|
} |
|
$unikey.=&add_prefix_and_part($prefix,$token->[2]->{'part'}); |
|
|
|
if (defined($token->[2]->{'id'})) { |
|
$unikey.='_'.$token->[2]->{'id'}; |
|
} |
|
|
|
if ($entry eq 'import') { |
if ($entry eq 'import') { |
# |
# |
# Importing a library here |
# Importing a library here |
# |
# |
|
my $location=$parser->get_text('/import'); |
|
my $dir=$filename; |
|
$dir=~s|[^/]*$||; |
|
$location=&filelocation($dir,$location); |
|
|
|
my $importmode=$token->[2]->{'importmode'}; |
|
if ($importmode eq 'problem') { |
|
# Import as problem/response |
|
$unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'}); |
|
} elsif ($importmode eq 'part') { |
|
# Import as part(s) |
|
$importedparts=1; |
|
# We need to get the original file and the imported file to get the part order correct |
|
# Good news: we do not need to worry about nested libraries, since parts cannot be nested |
|
# Load and inspect original file |
|
if ($#origfileimportpartids<0) { |
|
undef(%importedpartids); |
|
my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri); |
|
my $origfile=&getfile($origfilelocation); |
|
@origfileimportpartids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); |
|
} |
|
|
|
# Load and inspect imported file |
|
my $impfile=&getfile($location); |
|
my @impfilepartids=($impfile=~/<part[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); |
|
if ($#impfilepartids>=0) { |
|
# This problem had parts |
|
$importedpartids{$token->[2]->{'id'}}=join(',',@impfilepartids); |
|
} else { |
|
# Importing by turning a single problem into a problem part |
|
# It gets the import-tags ID as part-ID |
|
$unikey=&add_prefix_and_part($prefix,$token->[2]->{'id'}); |
|
$importedpartids{$token->[2]->{'id'}}=$token->[2]->{'id'}; |
|
} |
|
} else { |
|
# Normal import |
|
$unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'}); |
|
if (defined($token->[2]->{'id'})) { |
|
$unikey.='_'.$token->[2]->{'id'}; |
|
} |
|
} |
|
|
if ($depthcount<20) { |
if ($depthcount<20) { |
my $location=$parser->get_text('/import'); |
|
my $dir=$filename; |
|
$dir=~s|[^/]*$||; |
|
$location=&filelocation($dir,$location); |
|
my $metadata = |
my $metadata = |
&metadata($uri,'keys', $location,$unikey, |
&metadata($uri,'keys', $location,$unikey, |
$depthcount+1); |
$depthcount+1); |
Line 8811 sub metadata {
|
Line 8839 sub metadata {
|
$metaentry{':'.$meta}=$metaentry{':'.$meta}; |
$metaentry{':'.$meta}=$metaentry{':'.$meta}; |
$metathesekeys{$meta}=1; |
$metathesekeys{$meta}=1; |
} |
} |
} |
|
} else { |
} |
|
} else { |
|
# |
|
# Not importing, some other kind of non-package, non-library start tag |
|
# |
|
$unikey=$entry.&add_prefix_and_part($prefix,$token->[2]->{'part'}); |
|
if (defined($token->[2]->{'id'})) { |
|
$unikey.='_'.$token->[2]->{'id'}; |
|
} |
if (defined($token->[2]->{'name'})) { |
if (defined($token->[2]->{'name'})) { |
$unikey.='_'.$token->[2]->{'name'}; |
$unikey.='_'.$token->[2]->{'name'}; |
} |
} |
Line 8886 sub metadata {
|
Line 8922 sub metadata {
|
grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'})); |
grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'})); |
$metaentry{':packages'} = join(',',@uniq_packages); |
$metaentry{':packages'} = join(',',@uniq_packages); |
|
|
|
if ($importedparts) { |
|
# We had imported parts and need to rebuild partorder |
|
$metaentry{':partorder'}=''; |
|
$metathesekeys{'partorder'}=1; |
|
for (my $index=0;$index<$#origfileimportpartids;$index+=2) { |
|
if ($origfileimportpartids[$index] eq 'part') { |
|
# original part, part of the problem |
|
$metaentry{':partorder'}.=','.$origfileimportpartids[$index+1]; |
|
} else { |
|
# we have imported parts at this position |
|
$metaentry{':partorder'}.=','.$importedpartids{$origfileimportpartids[$index+1]}; |
|
} |
|
} |
|
$metaentry{':partorder'}=~s/^\,//; |
|
} |
|
|
$metaentry{':keys'} = join(',',keys(%metathesekeys)); |
$metaentry{':keys'} = join(',',keys(%metathesekeys)); |
&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri); |
&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri); |
$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys); |
$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys); |
Line 9070 sub symbverify {
|
Line 9122 sub symbverify {
|
$thisurl =~ s/\?.+$//; |
$thisurl =~ s/\?.+$//; |
} |
} |
my $ids=$bighash{'ids_'.&clutter($thisurl)}; |
my $ids=$bighash{'ids_'.&clutter($thisurl)}; |
unless ($ids) { |
unless ($ids) { |
my $idkey = 'ids_'.($thisurl =~ m{^/}? '' : '/').$thisurl; |
my $idkey = 'ids_'.($thisurl =~ m{^/}? '' : '/').$thisurl; |
$ids=$bighash{$idkey}; |
$ids=$bighash{$idkey}; |
} |
} |
if ($ids) { |
if ($ids) { |
# ------------------------------------------------------------------- Has ID(s) |
# ------------------------------------------------------------------- Has ID(s) |
Line 9086 sub symbverify {
|
Line 9138 sub symbverify {
|
eq $symb) { |
eq $symb) { |
if (($env{'request.role.adv'}) || |
if (($env{'request.role.adv'}) || |
($bighash{'encrypted_'.$id} eq $env{'request.enc'}) || |
($bighash{'encrypted_'.$id} eq $env{'request.enc'}) || |
($thisurl eq '/adm/navmaps')) { |
($thisurl eq '/adm/navmaps')) { |
$okay=1; |
$okay=1; |
} |
} |
} |
} |
Line 9843 sub filelocation {
|
Line 9895 sub filelocation {
|
my @ids=¤t_machine_ids(); |
my @ids=¤t_machine_ids(); |
foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } } |
foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } } |
if ($is_me) { |
if ($is_me) { |
$location=&propath($udom,$uname).'/userfiles/'.$filename; |
$location=propath($udom,$uname).'/userfiles/'.$filename; |
} else { |
} else { |
$location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'. |
$location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'. |
$udom.'/'.$uname.'/'.$filename; |
$udom.'/'.$uname.'/'.$filename; |
Line 10081 sub get_dns {
|
Line 10133 sub get_dns {
|
while (%alldns) { |
while (%alldns) { |
my ($dns) = keys(%alldns); |
my ($dns) = keys(%alldns); |
my $ua=new LWP::UserAgent; |
my $ua=new LWP::UserAgent; |
$ua->timeout(30); |
|
my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url"); |
my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url"); |
my $response=$ua->request($request); |
my $response=$ua->request($request); |
delete($alldns{$dns}); |
delete($alldns{$dns}); |
Line 10173 sub get_dns {
|
Line 10224 sub get_dns {
|
foreach my $configline (@$file) { |
foreach my $configline (@$file) { |
next if ($configline =~ /^(\#|\s*$ )/x); |
next if ($configline =~ /^(\#|\s*$ )/x); |
chomp($configline); |
chomp($configline); |
if ($configline =~ /^\^/) { |
if ($configline =~ /^\^/) { |
if ($configline =~ /^\^([\w.\-]+)/) { |
if ($configline =~ /^\^([\w.\-]+)/) { |
$LC_dns_serv{$1} = 1; |
$LC_dns_serv{$1} = 1; |
} |
} |
Line 10260 sub get_dns {
|
Line 10311 sub get_dns {
|
} |
} |
|
|
sub unique_library { |
sub unique_library { |
#2x reverse removes all hostnames that appear more than once |
#2x reverse removes all hostnames that appear more than once |
my %unique = reverse &all_library(); |
my %unique = reverse &all_library(); |
return reverse %unique; |
return reverse %unique; |
} |
} |
Line 10290 sub get_dns {
|
Line 10341 sub get_dns {
|
|
|
sub get_unique_servers { |
sub get_unique_servers { |
my %unique = reverse &get_servers(@_); |
my %unique = reverse &get_servers(@_); |
return reverse %unique; |
return reverse %unique; |
} |
} |
|
|
sub host_domain { |
sub host_domain { |
Line 10597 BEGIN {
|
Line 10648 BEGIN {
|
} |
} |
} |
} |
|
|
# ---------------------------------------------------------- Read managers table |
|
{ |
|
if (-e "$perlvar{'lonTabDir'}/managers.tab") { |
|
if (open(my $config,"<$perlvar{'lonTabDir'}/managers.tab")) { |
|
while (my $configline=<$config>) { |
|
chomp($configline); |
|
next if ($configline =~ /^\#/); |
|
if (($configline =~ /^[\w\-]+$/) || ($configline =~ /^[\w\-]+\:[\w\-]+$/)) { |
|
$managerstab{$configline} = 1; |
|
} |
|
} |
|
close($config); |
|
} |
|
} |
|
} |
|
|
|
# ------------- set up temporary directory |
# ------------- set up temporary directory |
{ |
{ |
$tmpdir = $perlvar{'lonDaemons'}.'/tmp/'; |
$tmpdir = LONCAPA::tempdir(); |
|
|
} |
} |
|
|
Line 10850 $checkdefauth is optional (value is 1 if
|
Line 10885 $checkdefauth is optional (value is 1 if
|
authenticate user using default authentication method, and allow |
authenticate user using default authentication method, and allow |
account creation if username does not have account in the domain). |
account creation if username does not have account in the domain). |
$clientcancheckhost is optional (value is 1 if checking whether the |
$clientcancheckhost is optional (value is 1 if checking whether the |
server can host will occur on the client side in lonauth.pm). |
server can host will occur on the client side in lonauth.pm). |
|
|
=item * |
=item * |
X<homeserver()> |
X<homeserver()> |
Line 11109 revokecustomrole($udom,$uname,$url,$role
|
Line 11144 revokecustomrole($udom,$uname,$url,$role
|
|
|
=item * |
=item * |
|
|
coursedescription($courseid) : returns a hash of information about the |
coursedescription($courseid,$options) : returns a hash of information about the |
specified course id, including all environment settings for the |
specified course id, including all environment settings for the |
course, the description of the course will be in the hash under the |
course, the description of the course will be in the hash under the |
key 'description' |
key 'description' |
|
|
|
$options is an optional parameter that if supplied is a hash reference that controls |
|
what how this function works. It has the following key/values: |
|
|
|
=over 4 |
|
|
|
=item freshen_cache |
|
|
|
If defined, and the environment cache for the course is valid, it is |
|
returned in the returned hash. |
|
|
|
=item one_time |
|
|
|
If defined, the last cache time is set to _now_ |
|
|
|
=item user |
|
|
|
If defined, the supplied username is used instead of the current user. |
|
|
|
|
|
=back |
|
|
=item * |
=item * |
|
|
resdata($name,$domain,$type,@which) : request for current parameter |
resdata($name,$domain,$type,@which) : request for current parameter |
Line 11506 splitting on '&', supports elements that
|
Line 11562 splitting on '&', supports elements that
|
|
|
=head2 Logging Routines |
=head2 Logging Routines |
|
|
|
|
These routines allow one to make log messages in the lonnet.log and |
These routines allow one to make log messages in the lonnet.log and |
lonnet.perm logfiles. |
lonnet.perm logfiles. |
|
|
Line 11526 logperm() : append a permanent message t
|
Line 11583 logperm() : append a permanent message t
|
file never gets deleted by any automated portion of the system, only |
file never gets deleted by any automated portion of the system, only |
messages of critical importance should go in here. |
messages of critical importance should go in here. |
|
|
|
|
=back |
=back |
|
|
=head2 General File Helper Routines |
=head2 General File Helper Routines |
Line 11600 userfileupload(): main rotine for puttin
|
Line 11658 userfileupload(): main rotine for puttin
|
the filename is in $env{'form.'.$formname.'.filename'} and the |
the filename is in $env{'form.'.$formname.'.filename'} and the |
contents of the file is located in $env{'form.'.$formname} |
contents of the file is located in $env{'form.'.$formname} |
context - if coursedoc, store the file in the course of the active role |
context - if coursedoc, store the file in the course of the active role |
of the current user; |
of the current user; |
if 'existingfile': store in 'overwrites' in /home/httpd/perl/tmp |
if 'existingfile': store in 'overwrites' in /home/httpd/perl/tmp |
if 'canceloverwrite': delete file in tmp/overwrites directory |
if 'canceloverwrite': delete file in tmp/overwrites directory |
subdir - required - subdirectory to put the file in under ../userfiles/ |
subdir - required - subdirectory to put the file in under ../userfiles/ |
Line 11646 userspace, probably shouldn't be called
|
Line 11704 userspace, probably shouldn't be called
|
returns either the url of the uploaded file (/uploaded/....) if successful |
returns either the url of the uploaded file (/uploaded/....) if successful |
and /adm/notfound.html if unsuccessful (or an error message if context |
and /adm/notfound.html if unsuccessful (or an error message if context |
was 'overwrite'). |
was 'overwrite'). |
|
|
|
|
=item * |
=item * |
|
|