|
version 1.768, 2006/08/04 19:42:59
|
version 1.791, 2006/10/13 04:23:15
|
|
Line 52 use Storable qw(lock_store lock_nstore l
|
Line 52 use Storable qw(lock_store lock_nstore l
|
| use Time::HiRes qw( gettimeofday tv_interval ); |
use Time::HiRes qw( gettimeofday tv_interval ); |
| use Cache::Memcached; |
use Cache::Memcached; |
| use Digest::MD5; |
use Digest::MD5; |
| |
use Math::Random; |
| use lib '/home/httpd/lib/perl'; |
use lib '/home/httpd/lib/perl'; |
| use LONCAPA; |
use LONCAPA; |
| use LONCAPA::Configuration; |
use LONCAPA::Configuration; |
|
Line 292 sub error {
|
Line 293 sub error {
|
| return undef; |
return undef; |
| } |
} |
| |
|
| # ------------------------------------------- Transfer profile into environment |
sub convert_and_load_session_env { |
| |
my ($lonidsdir,$handle)=@_; |
| |
my @profile; |
| |
{ |
| |
open(my $idf,"$lonidsdir/$handle.id"); |
| |
flock($idf,LOCK_SH); |
| |
@profile=<$idf>; |
| |
close($idf); |
| |
} |
| |
my %temp_env; |
| |
foreach my $line (@profile) { |
| |
if ($line !~ m/=/) { |
| |
return 0; |
| |
} |
| |
chomp($line); |
| |
my ($envname,$envvalue)=split(/=/,$line,2); |
| |
$temp_env{&unescape($envname)} = &unescape($envvalue); |
| |
} |
| |
unlink("$lonidsdir/$handle.id"); |
| |
if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_WRCREAT(), |
| |
0640)) { |
| |
%disk_env = %temp_env; |
| |
@env{keys(%temp_env)} = @disk_env{keys(%temp_env)}; |
| |
untie(%disk_env); |
| |
} |
| |
return 1; |
| |
} |
| |
|
| |
# ------------------------------------------- Transfer profile into environment |
| |
my $env_loaded; |
| sub transfer_profile_to_env { |
sub transfer_profile_to_env { |
| my ($lonidsdir,$handle)=@_; |
my ($lonidsdir,$handle,$force_transfer) = @_; |
| |
if (!$force_transfer && $env_loaded) { return; } |
| |
|
| if (!defined($lonidsdir)) { |
if (!defined($lonidsdir)) { |
| $lonidsdir = $perlvar{'lonIDsDir'}; |
$lonidsdir = $perlvar{'lonIDsDir'}; |
| } |
} |
|
Line 303 sub transfer_profile_to_env {
|
Line 334 sub transfer_profile_to_env {
|
| ($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| ); |
($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| ); |
| } |
} |
| |
|
| my @profile; |
my $convert; |
| { |
{ |
| open(my $idf,"$lonidsdir/$handle.id"); |
open(my $idf,"$lonidsdir/$handle.id"); |
| flock($idf,LOCK_SH); |
flock($idf,LOCK_SH); |
| @profile=<$idf>; |
if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id", |
| close($idf); |
&GDBM_READER(),0640)) { |
| |
@env{keys(%disk_env)} = @disk_env{keys(%disk_env)}; |
| |
untie(%disk_env); |
| |
} else { |
| |
$convert = 1; |
| |
} |
| |
} |
| |
if ($convert) { |
| |
if (!&convert_and_load_session_env($lonidsdir,$handle)) { |
| |
&logthis("Failed to load session, or convert session."); |
| |
} |
| } |
} |
| my $envi; |
|
| my %Remove; |
my %remove; |
| for ($envi=0;$envi<=$#profile;$envi++) { |
while ( my $envname = each(%env) ) { |
| chomp($profile[$envi]); |
|
| my ($envname,$envvalue)=split(/=/,$profile[$envi],2); |
|
| $envname=&unescape($envname); |
|
| $envvalue=&unescape($envvalue); |
|
| $env{$envname} = $envvalue; |
|
| if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) { |
if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) { |
| if ($time < time-300) { |
if ($time < time-300) { |
| $Remove{$key}++; |
$remove{$key}++; |
| } |
} |
| } |
} |
| } |
} |
| |
|
| $env{'user.environment'} = "$lonidsdir/$handle.id"; |
$env{'user.environment'} = "$lonidsdir/$handle.id"; |
| foreach my $expired_key (keys(%Remove)) { |
$env_loaded=1; |
| |
foreach my $expired_key (keys(%remove)) { |
| &delenv($expired_key); |
&delenv($expired_key); |
| } |
} |
| } |
} |
|
Line 344 sub appenv {
|
Line 382 sub appenv {
|
| $env{$key}=$newenv{$key}; |
$env{$key}=$newenv{$key}; |
| } |
} |
| } |
} |
| |
if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(), |
| my $lockfh; |
0640)) { |
| unless (open($lockfh,"$env{'user.environment'}")) { |
while (my ($key,$value) = each(%newenv)) { |
| return 'error: '.$!; |
$disk_env{$key} = $value; |
| } |
|
| unless (flock($lockfh,LOCK_EX)) { |
|
| &logthis("<font color=\"blue\">WARNING: ". |
|
| 'Could not obtain exclusive lock in appenv: '.$!); |
|
| close($lockfh); |
|
| return 'error: '.$!; |
|
| } |
|
| |
|
| my @oldenv; |
|
| { |
|
| my $fh; |
|
| unless (open($fh,"$env{'user.environment'}")) { |
|
| return 'error: '.$!; |
|
| } |
|
| @oldenv=<$fh>; |
|
| close($fh); |
|
| } |
|
| for (my $i=0; $i<=$#oldenv; $i++) { |
|
| chomp($oldenv[$i]); |
|
| if ($oldenv[$i] ne '') { |
|
| my ($name,$value)=split(/=/,$oldenv[$i],2); |
|
| $name=&unescape($name); |
|
| $value=&unescape($value); |
|
| unless (defined($newenv{$name})) { |
|
| $newenv{$name}=$value; |
|
| } |
|
| } |
|
| } |
|
| { |
|
| my $fh; |
|
| unless (open($fh,">$env{'user.environment'}")) { |
|
| return 'error'; |
|
| } |
|
| my $newname; |
|
| foreach $newname (keys %newenv) { |
|
| print $fh &escape($newname).'='.&escape($newenv{$newname})."\n"; |
|
| } |
} |
| close($fh); |
untie(%disk_env); |
| } |
} |
| |
|
| close($lockfh); |
|
| return 'ok'; |
return 'ok'; |
| } |
} |
| # ----------------------------------------------------- Delete from Environment |
# ----------------------------------------------------- Delete from Environment |
|
Line 400 sub delenv {
|
Line 400 sub delenv {
|
| "Attempt to delete from environment ".$delthis); |
"Attempt to delete from environment ".$delthis); |
| return 'error'; |
return 'error'; |
| } |
} |
| my @oldenv; |
if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(), |
| { |
0640)) { |
| my $fh; |
foreach my $key (keys(%disk_env)) { |
| unless (open($fh,"$env{'user.environment'}")) { |
if ($key=~/^$delthis/) { |
| return 'error'; |
|
| } |
|
| unless (flock($fh,LOCK_SH)) { |
|
| &logthis("<font color=\"blue\">WARNING: ". |
|
| 'Could not obtain shared lock in delenv: '.$!); |
|
| close($fh); |
|
| return 'error: '.$!; |
|
| } |
|
| @oldenv=<$fh>; |
|
| close($fh); |
|
| } |
|
| { |
|
| my $fh; |
|
| unless (open($fh,">$env{'user.environment'}")) { |
|
| return 'error'; |
|
| } |
|
| unless (flock($fh,LOCK_EX)) { |
|
| &logthis("<font color=\"blue\">WARNING: ". |
|
| 'Could not obtain exclusive lock in delenv: '.$!); |
|
| close($fh); |
|
| return 'error: '.$!; |
|
| } |
|
| foreach my $cur_key (@oldenv) { |
|
| my $unescaped_cur_key = &unescape($cur_key); |
|
| if ($unescaped_cur_key=~/^$delthis/) { |
|
| my ($key) = split('=',$cur_key,2); |
|
| $key = &unescape($key); |
|
| delete($env{$key}); |
delete($env{$key}); |
| } else { |
delete($disk_env{$key}); |
| print $fh $cur_key; |
|
| } |
} |
| } |
} |
| close($fh); |
untie(%disk_env); |
| } |
} |
| return 'ok'; |
return 'ok'; |
| } |
} |
| |
|
| |
=pod |
| |
|
| |
=item * get_env_multiple($name) |
| |
|
| |
gets $name from the %env hash, it seemlessly handles the cases where multiple |
| |
values may be defined and end up as an array ref. |
| |
|
| |
returns an array of values |
| |
|
| |
=cut |
| |
|
| |
sub get_env_multiple { |
| |
my ($name) = @_; |
| |
my @values; |
| |
if (defined($env{$name})) { |
| |
# exists is it an array |
| |
if (ref($env{$name})) { |
| |
@values=@{ $env{$name} }; |
| |
} else { |
| |
$values[0]=$env{$name}; |
| |
} |
| |
} |
| |
return(@values); |
| |
} |
| |
|
| # ------------------------------------------ Find out current server userload |
# ------------------------------------------ Find out current server userload |
| # there is a copy in lond |
# there is a copy in lond |
| sub userload { |
sub userload { |
|
Line 493 sub overloaderror {
|
Line 490 sub overloaderror {
|
| |
|
| sub spareserver { |
sub spareserver { |
| my ($loadpercent,$userloadpercent,$want_server_name) = @_; |
my ($loadpercent,$userloadpercent,$want_server_name) = @_; |
| my $tryserver; |
my $spare_server; |
| my $spareserver=''; |
|
| if ($userloadpercent !~ /\d/) { $userloadpercent=0; } |
if ($userloadpercent !~ /\d/) { $userloadpercent=0; } |
| my $lowestserver=$loadpercent > $userloadpercent? |
my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent |
| $loadpercent : $userloadpercent; |
: $userloadpercent; |
| foreach $tryserver (keys(%spareid)) { |
|
| my $loadans=&reply('load',$tryserver); |
foreach my $try_server (@{ $spareid{'primary'} }) { |
| my $userloadans=&reply('userload',$tryserver); |
($spare_server, $lowest_load) = |
| if ($loadans !~ /\d/ && $userloadans !~ /\d/) { |
&compare_server_load($try_server, $spare_server, $lowest_load); |
| next; #didn't get a number from the server |
} |
| } |
|
| my $answer; |
my $found_server = ($spare_server ne '' && $lowest_load < 100); |
| if ($loadans =~ /\d/) { |
|
| if ($userloadans =~ /\d/) { |
if (!$found_server) { |
| #both are numbers, pick the bigger one |
foreach my $try_server (@{ $spareid{'default'} }) { |
| $answer=$loadans > $userloadans? |
($spare_server, $lowest_load) = |
| $loadans : $userloadans; |
&compare_server_load($try_server, $spare_server, $lowest_load); |
| } else { |
|
| $answer = $loadans; |
|
| } |
|
| } else { |
|
| $answer = $userloadans; |
|
| } |
|
| if (($answer =~ /\d/) && ($answer<$lowestserver)) { |
|
| if ($want_server_name) { |
|
| $spareserver=$tryserver; |
|
| } else { |
|
| $spareserver="http://$hostname{$tryserver}"; |
|
| } |
|
| $lowestserver=$answer; |
|
| } |
} |
| } |
} |
| return $spareserver; |
|
| |
if (!$want_server_name) { |
| |
$spare_server="http://$hostname{$spare_server}"; |
| |
} |
| |
return $spare_server; |
| } |
} |
| |
|
| |
sub compare_server_load { |
| |
my ($try_server, $spare_server, $lowest_load) = @_; |
| |
|
| |
my $loadans = &reply('load', $try_server); |
| |
my $userloadans = &reply('userload',$try_server); |
| |
|
| |
if ($loadans !~ /\d/ && $userloadans !~ /\d/) { |
| |
next; #didn't get a number from the server |
| |
} |
| |
|
| |
my $load; |
| |
if ($loadans =~ /\d/) { |
| |
if ($userloadans =~ /\d/) { |
| |
#both are numbers, pick the bigger one |
| |
$load = ($loadans > $userloadans) ? $loadans |
| |
: $userloadans; |
| |
} else { |
| |
$load = $loadans; |
| |
} |
| |
} else { |
| |
$load = $userloadans; |
| |
} |
| |
|
| |
if (($load =~ /\d/) && ($load < $lowest_load)) { |
| |
$spare_server = $try_server; |
| |
$lowest_load = $load; |
| |
} |
| |
return ($spare_server,$lowest_load); |
| |
} |
| # --------------------------------------------- Try to change a user's password |
# --------------------------------------------- Try to change a user's password |
| |
|
| sub changepass { |
sub changepass { |
|
Line 891 sub save_cache {
|
Line 907 sub save_cache {
|
| &purge_remembered(); |
&purge_remembered(); |
| #&Apache::loncommon::validate_page(); |
#&Apache::loncommon::validate_page(); |
| undef(%env); |
undef(%env); |
| |
undef($env_loaded); |
| } |
} |
| |
|
| my $to_remember=-1; |
my $to_remember=-1; |
|
Line 1176 sub ssi_body {
|
Line 1193 sub ssi_body {
|
| } |
} |
| my $output=($filelink=~/^http\:/?&externalssi($filelink): |
my $output=($filelink=~/^http\:/?&externalssi($filelink): |
| &ssi($filelink,%form)); |
&ssi($filelink,%form)); |
| $output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+// END LON-CAPA Internal\s*(-->)?\s||gs; |
$output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s*(-->)?\s||gs; |
| $output=~s/^.*?\<body[^\>]*\>//si; |
$output=~s/^.*?\<body[^\>]*\>//si; |
| $output=~s/(.*)\<\/body\s*\>.*?$/$1/si; |
$output=~s/(.*)\<\/body\s*\>.*?$/$1/si; |
| return $output; |
return $output; |
|
Line 1184 sub ssi_body {
|
Line 1201 sub ssi_body {
|
| |
|
| # --------------------------------------------------------- Server Side Include |
# --------------------------------------------------------- Server Side Include |
| |
|
| |
sub absolute_url { |
| |
my ($host_name) = @_; |
| |
my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://'); |
| |
if ($host_name eq '') { |
| |
$host_name = $ENV{'SERVER_NAME'}; |
| |
} |
| |
return $protocol.$host_name; |
| |
} |
| |
|
| sub ssi { |
sub ssi { |
| |
|
| my ($fn,%form)=@_; |
my ($fn,%form)=@_; |
|
Line 1195 sub ssi {
|
Line 1221 sub ssi {
|
| $form{'no_update_last_known'}=1; |
$form{'no_update_last_known'}=1; |
| |
|
| if (%form) { |
if (%form) { |
| $request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn); |
$request=new HTTP::Request('POST',&absolute_url().$fn); |
| $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form)); |
$request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form)); |
| } else { |
} else { |
| $request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn); |
$request=new HTTP::Request('GET',&absolute_url().$fn); |
| } |
} |
| |
|
| $request->header(Cookie => $ENV{'HTTP_COOKIE'}); |
$request->header(Cookie => $ENV{'HTTP_COOKIE'}); |
|
Line 1953 sub courseidput {
|
Line 1979 sub courseidput {
|
| } |
} |
| |
|
| sub courseiddump { |
sub courseiddump { |
| my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter)=@_; |
my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_; |
| my %returnhash=(); |
my %returnhash=(); |
| unless ($domfilter) { $domfilter=''; } |
unless ($domfilter) { $domfilter=''; } |
| foreach my $tryserver (keys %libserv) { |
foreach my $tryserver (keys %libserv) { |
|
Line 1962 sub courseiddump {
|
Line 1988 sub courseiddump {
|
| foreach ( |
foreach ( |
| split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'. |
split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'. |
| $sincefilter.':'.&escape($descfilter).':'. |
$sincefilter.':'.&escape($descfilter).':'. |
| &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter), |
&escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter).':'.&escape($regexp_ok), |
| $tryserver))) { |
$tryserver))) { |
| my ($key,$value)=split(/\=/,$_); |
my ($key,$value)=split(/\=/,$_); |
| if (($key) && ($value)) { |
if (($key) && ($value)) { |
|
Line 2035 sub get_domain_roles {
|
Line 2061 sub get_domain_roles {
|
| |
|
| sub get_first_access { |
sub get_first_access { |
| my ($type,$argsymb)=@_; |
my ($type,$argsymb)=@_; |
| my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser(); |
my ($symb,$courseid,$udom,$uname)=&whichuser(); |
| if ($argsymb) { $symb=$argsymb; } |
if ($argsymb) { $symb=$argsymb; } |
| my ($map,$id,$res)=&decode_symb($symb); |
my ($map,$id,$res)=&decode_symb($symb); |
| if ($type eq 'map') { |
if ($type eq 'map') { |
|
Line 2049 sub get_first_access {
|
Line 2075 sub get_first_access {
|
| |
|
| sub set_first_access { |
sub set_first_access { |
| my ($type)=@_; |
my ($type)=@_; |
| my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser(); |
my ($symb,$courseid,$udom,$uname)=&whichuser(); |
| my ($map,$id,$res)=&decode_symb($symb); |
my ($map,$id,$res)=&decode_symb($symb); |
| if ($type eq 'map') { |
if ($type eq 'map') { |
| $res=&symbread($map); |
$res=&symbread($map); |
|
Line 2845 sub set_userprivs {
|
Line 2871 sub set_userprivs {
|
| if (keys(%{$allgroups}) > 0) { |
if (keys(%{$allgroups}) > 0) { |
| foreach my $role (keys %{$allroles}) { |
foreach my $role (keys %{$allroles}) { |
| my ($trole,$area,$sec,$extendedarea); |
my ($trole,$area,$sec,$extendedarea); |
| if ($role =~ m|^(\w+)\.(/\w+/\w+)(/?\w*)|) { |
if ($role =~ m-^(\w+|cr/\w+/\w+/\w+)\.(/\w+/\w+)(/?\w*)-) { |
| $trole = $1; |
$trole = $1; |
| $area = $2; |
$area = $2; |
| $sec = $3; |
$sec = $3; |
|
Line 3474 sub allowed {
|
Line 3500 sub allowed {
|
| |
|
| if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; } |
if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; } |
| # Free bre access to adm and meta resources |
# Free bre access to adm and meta resources |
| if (((($uri=~/^adm\//) && ($uri !~ m|/bulletinboard$|)) |
if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard)$})) |
| || ($uri=~/\.meta$/)) && ($priv eq 'bre')) { |
|| (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) |
| |
&& ($priv eq 'bre')) { |
| return 'F'; |
return 'F'; |
| } |
} |
| |
|
|
Line 4073 sub auto_run {
|
Line 4100 sub auto_run {
|
| my $response = &reply('autorun:'.$cdom,$homeserver); |
my $response = &reply('autorun:'.$cdom,$homeserver); |
| return $response; |
return $response; |
| } |
} |
| |
|
| sub auto_get_sections { |
sub auto_get_sections { |
| my ($cnum,$cdom,$inst_coursecode) = @_; |
my ($cnum,$cdom,$inst_coursecode) = @_; |
| my $homeserver = &homeserver($cnum,$cdom); |
my $homeserver = &homeserver($cnum,$cdom); |
|
Line 4084 sub auto_get_sections {
|
Line 4111 sub auto_get_sections {
|
| } |
} |
| return @secs; |
return @secs; |
| } |
} |
| |
|
| sub auto_new_course { |
sub auto_new_course { |
| my ($cnum,$cdom,$inst_course_id,$owner) = @_; |
my ($cnum,$cdom,$inst_course_id,$owner) = @_; |
| my $homeserver = &homeserver($cnum,$cdom); |
my $homeserver = &homeserver($cnum,$cdom); |
| my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner.':'.$cdom,$homeserver)); |
my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner.':'.$cdom,$homeserver)); |
| return $response; |
return $response; |
| } |
} |
| |
|
| sub auto_validate_courseID { |
sub auto_validate_courseID { |
| my ($cnum,$cdom,$inst_course_id) = @_; |
my ($cnum,$cdom,$inst_course_id) = @_; |
| my $homeserver = &homeserver($cnum,$cdom); |
my $homeserver = &homeserver($cnum,$cdom); |
| my $response=&unescape(&reply('autovalidatecourse:'.$inst_course_id.':'.$cdom,$homeserver)); |
my $response=&unescape(&reply('autovalidatecourse:'.$inst_course_id.':'.$cdom,$homeserver)); |
| return $response; |
return $response; |
| } |
} |
| |
|
| sub auto_create_password { |
sub auto_create_password { |
| my ($cnum,$cdom,$authparam) = @_; |
my ($cnum,$cdom,$authparam) = @_; |
| my $homeserver = &homeserver($cnum,$cdom); |
my $homeserver = &homeserver($cnum,$cdom); |
|
Line 4192 sub auto_photoupdate {
|
Line 4219 sub auto_photoupdate {
|
| sub auto_instcode_format { |
sub auto_instcode_format { |
| my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,$cat_order) = @_; |
my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,$cat_order) = @_; |
| my $courses = ''; |
my $courses = ''; |
| my $homeserver; |
my @homeservers; |
| if ($caller eq 'global') { |
if ($caller eq 'global') { |
| foreach my $tryserver (keys %libserv) { |
foreach my $tryserver (keys %libserv) { |
| if ($hostdom{$tryserver} eq $codedom) { |
if ($hostdom{$tryserver} eq $codedom) { |
| $homeserver = $tryserver; |
if (!grep/^\Q$tryserver\E$/,@homeservers) { |
| last; |
push(@homeservers,$tryserver); |
| |
} |
| } |
} |
| } |
} |
| if (($env{'user.name'}) && ($env{'user.domain'} eq $codedom)) { |
|
| $homeserver = &homeserver($env{'user.name'},$codedom); |
|
| } |
|
| } else { |
} else { |
| $homeserver = &homeserver($caller,$codedom); |
push(@homeservers,&homeserver($caller,$codedom)); |
| } |
} |
| foreach (keys %{$instcodes}) { |
foreach (keys %{$instcodes}) { |
| $courses .= &escape($_).'='.&escape($$instcodes{$_}).'&'; |
$courses .= &escape($_).'='.&escape($$instcodes{$_}).'&'; |
| } |
} |
| chop($courses); |
chop($courses); |
| my $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$homeserver); |
my $ok_response = 0; |
| unless ($response =~ /(con_lost|error|no_such_host|refused)/) { |
my $response; |
| my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = split/:/,$response; |
while (@homeservers > 0 && $ok_response == 0) { |
| %{$codes} = &str2hash($codes_str); |
my $server = shift(@homeservers); |
| @{$codetitles} = &str2array($codetitles_str); |
$response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server); |
| %{$cat_titles} = &str2hash($cat_titles_str); |
if ($response !~ /(con_lost|error|no_such_host|refused)/) { |
| %{$cat_order} = &str2hash($cat_order_str); |
my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = |
| |
split/:/,$response; |
| |
%{$codes} = (%{$codes},&str2hash($codes_str)); |
| |
push(@{$codetitles},&str2array($codetitles_str)); |
| |
%{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str)); |
| |
%{$cat_order} = (%{$cat_order},&str2hash($cat_order_str)); |
| |
$ok_response = 1; |
| |
} |
| |
} |
| |
if ($ok_response) { |
| return 'ok'; |
return 'ok'; |
| |
} else { |
| |
return $response; |
| } |
} |
| |
} |
| |
|
| |
sub auto_validate_class_sec { |
| |
my ($cdom,$cnum,$owner,$inst_class) = @_; |
| |
my $homeserver = &homeserver($cnum,$cdom); |
| |
my $response=&reply('autovalidateclass_sec:'.$inst_class.':'. |
| |
&escape($owner).':'.$cdom,$homeserver); |
| return $response; |
return $response; |
| } |
} |
| |
|
|
Line 4914 sub get_portfile_permissions {
|
Line 4957 sub get_portfile_permissions {
|
| |
|
| sub get_access_controls { |
sub get_access_controls { |
| my ($current_permissions,$group,$file) = @_; |
my ($current_permissions,$group,$file) = @_; |
| my %access; |
my %access; |
| |
my $real_file = $file; |
| |
$file =~ s/\.meta$//; |
| if (defined($file)) { |
if (defined($file)) { |
| if (ref($$current_permissions{$file."\0".'accesscontrol'}) eq 'HASH') { |
if (ref($$current_permissions{$file."\0".'accesscontrol'}) eq 'HASH') { |
| foreach my $control (keys(%{$$current_permissions{$file."\0".'accesscontrol'}})) { |
foreach my $control (keys(%{$$current_permissions{$file."\0".'accesscontrol'}})) { |
| $access{$file}{$control} = $$current_permissions{$file."\0".$control}; |
$access{$real_file}{$control} = $$current_permissions{$file."\0".$control}; |
| } |
} |
| } |
} |
| } else { |
} else { |
|
Line 5258 sub GetFileTimestamp {
|
Line 5303 sub GetFileTimestamp {
|
| |
|
| sub stat_file { |
sub stat_file { |
| my ($uri) = @_; |
my ($uri) = @_; |
| $uri = &clutter($uri); |
$uri = &clutter_with_no_wrapper($uri); |
| |
|
| # we want just the url part without the unneeded accessor url bits |
|
| if ($uri =~ m-^/adm/-) { |
|
| $uri=~s-^/adm/wrapper/-/-; |
|
| $uri=~s-^/adm/coursedocs/showdoc/-/-; |
|
| } |
|
| my ($udom,$uname,$file,$dir); |
my ($udom,$uname,$file,$dir); |
| if ($uri =~ m-^/(uploaded|editupload)/-) { |
if ($uri =~ m-^/(uploaded|editupload)/-) { |
| ($udom,$uname,$file) = |
($udom,$uname,$file) = |
|
Line 5496 sub EXT {
|
Line 5536 sub EXT {
|
| $symbparm=&get_symb_from_alias($symbparm); |
$symbparm=&get_symb_from_alias($symbparm); |
| } |
} |
| if (!($uname && $udom)) { |
if (!($uname && $udom)) { |
| (my $cursymb,$courseid,$udom,$uname,$publicuser)= |
(my $cursymb,$courseid,$udom,$uname,$publicuser)= &whichuser($symbparm); |
| &Apache::lonxml::whichuser($symbparm); |
|
| if (!$symbparm) { $symbparm=$cursymb; } |
if (!$symbparm) { $symbparm=$cursymb; } |
| } else { |
} else { |
| $courseid=$env{'request.course.id'}; |
$courseid=$env{'request.course.id'}; |
|
Line 5734 sub EXT {
|
Line 5773 sub EXT {
|
| if (($uname eq $env{'user.name'})&&($udom eq $env{'user.domain'})) { |
if (($uname eq $env{'user.name'})&&($udom eq $env{'user.domain'})) { |
| return $env{'environment.'.$spacequalifierrest}; |
return $env{'environment.'.$spacequalifierrest}; |
| } else { |
} else { |
| |
if ($uname eq 'anonymous' && $udom eq '') { |
| |
return ''; |
| |
} |
| my %returnhash=&userenvironment($udom,$uname, |
my %returnhash=&userenvironment($udom,$uname, |
| $spacequalifierrest); |
$spacequalifierrest); |
| return $returnhash{$spacequalifierrest}; |
return $returnhash{$spacequalifierrest}; |
|
Line 6148 sub gettitle {
|
Line 6190 sub gettitle {
|
| sub get_slot { |
sub get_slot { |
| my ($which,$cnum,$cdom)=@_; |
my ($which,$cnum,$cdom)=@_; |
| if (!$cnum || !$cdom) { |
if (!$cnum || !$cdom) { |
| (undef,my $courseid)=&Apache::lonxml::whichuser(); |
(undef,my $courseid)=&whichuser(); |
| $cdom=$env{'course.'.$courseid.'.domain'}; |
$cdom=$env{'course.'.$courseid.'.domain'}; |
| $cnum=$env{'course.'.$courseid.'.num'}; |
$cnum=$env{'course.'.$courseid.'.num'}; |
| } |
} |
|
Line 6197 sub symblist {
|
Line 6239 sub symblist {
|
| sub symbverify { |
sub symbverify { |
| my ($symb,$thisurl)=@_; |
my ($symb,$thisurl)=@_; |
| my $thisfn=$thisurl; |
my $thisfn=$thisurl; |
| # wrapper not part of symbs |
|
| $thisfn=~s/^\/adm\/wrapper//; |
|
| $thisfn=~s/^\/adm\/coursedocs\/showdoc\///; |
|
| $thisfn=&declutter($thisfn); |
$thisfn=&declutter($thisfn); |
| # direct jump to resource in page or to a sequence - will construct own symbs |
# direct jump to resource in page or to a sequence - will construct own symbs |
| if ($thisfn=~/\.(page|sequence)$/) { return 1; } |
if ($thisfn=~/\.(page|sequence)$/) { return 1; } |
|
Line 6482 sub latest_rnd_algorithm_id {
|
Line 6521 sub latest_rnd_algorithm_id {
|
| |
|
| sub get_rand_alg { |
sub get_rand_alg { |
| my ($courseid)=@_; |
my ($courseid)=@_; |
| if (!$courseid) { $courseid=(&Apache::lonxml::whichuser())[1]; } |
if (!$courseid) { $courseid=(&whichuser())[1]; } |
| if ($courseid) { |
if ($courseid) { |
| return $env{"course.$courseid.rndseed"}; |
return $env{"course.$courseid.rndseed"}; |
| } |
} |
|
Line 6508 sub getCODE {
|
Line 6547 sub getCODE {
|
| sub rndseed { |
sub rndseed { |
| my ($symb,$courseid,$domain,$username)=@_; |
my ($symb,$courseid,$domain,$username)=@_; |
| |
|
| my ($wsymb,$wcourseid,$wdomain,$wusername)=&Apache::lonxml::whichuser(); |
my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser(); |
| if (!$symb) { |
if (!$symb) { |
| unless ($symb=$wsymb) { return time; } |
unless ($symb=$wsymb) { return time; } |
| } |
} |
|
Line 6549 sub rndseed_32bit {
|
Line 6588 sub rndseed_32bit {
|
| my $domainseed=unpack("%32C*",$domain) << 7; |
my $domainseed=unpack("%32C*",$domain) << 7; |
| my $courseseed=unpack("%32C*",$courseid); |
my $courseseed=unpack("%32C*",$courseid); |
| my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck; |
my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck; |
| #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
#&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
| #&Apache::lonxml::debug("rndseed :$num:$symb"); |
#&logthis("rndseed :$num:$symb"); |
| if ($_64bit) { $num=(($num<<32)>>32); } |
if ($_64bit) { $num=(($num<<32)>>32); } |
| return $num; |
return $num; |
| } |
} |
|
Line 6570 sub rndseed_64bit {
|
Line 6609 sub rndseed_64bit {
|
| |
|
| my $num1=$symbchck+$symbseed+$namechck; |
my $num1=$symbchck+$symbseed+$namechck; |
| my $num2=$nameseed+$domainseed+$courseseed; |
my $num2=$nameseed+$domainseed+$courseseed; |
| #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
#&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
| #&Apache::lonxml::debug("rndseed :$num:$symb"); |
#&logthis("rndseed :$num:$symb"); |
| if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } |
if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } |
| if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } |
if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } |
| return "$num1,$num2"; |
return "$num1,$num2"; |
|
Line 6594 sub rndseed_64bit2 {
|
Line 6633 sub rndseed_64bit2 {
|
| |
|
| my $num1=$symbchck+$symbseed+$namechck; |
my $num1=$symbchck+$symbseed+$namechck; |
| my $num2=$nameseed+$domainseed+$courseseed; |
my $num2=$nameseed+$domainseed+$courseseed; |
| #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
#&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
| #&Apache::lonxml::debug("rndseed :$num:$symb"); |
#&logthis("rndseed :$num:$symb"); |
| return "$num1,$num2"; |
return "$num1,$num2"; |
| } |
} |
| } |
} |
|
Line 6616 sub rndseed_64bit3 {
|
Line 6655 sub rndseed_64bit3 {
|
| |
|
| my $num1=$symbchck+$symbseed+$namechck; |
my $num1=$symbchck+$symbseed+$namechck; |
| my $num2=$nameseed+$domainseed+$courseseed; |
my $num2=$nameseed+$domainseed+$courseseed; |
| #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
#&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
| #&Apache::lonxml::debug("rndseed :$num1:$num2:$_64bit"); |
#&logthis("rndseed :$num1:$num2:$_64bit"); |
| if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } |
if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } |
| |
|
| return "$num1:$num2"; |
return "$num1:$num2"; |
|
Line 6640 sub rndseed_64bit4 {
|
Line 6679 sub rndseed_64bit4 {
|
| |
|
| my $num1=$symbchck+$symbseed+$namechck; |
my $num1=$symbchck+$symbseed+$namechck; |
| my $num2=$nameseed+$domainseed+$courseseed; |
my $num2=$nameseed+$domainseed+$courseseed; |
| #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
#&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
| #&Apache::lonxml::debug("rndseed :$num1:$num2:$_64bit"); |
#&logthis("rndseed :$num1:$num2:$_64bit"); |
| if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } |
if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } |
| |
|
| return "$num1:$num2"; |
return "$num1:$num2"; |
|
Line 6665 sub rndseed_CODE_64bit {
|
Line 6704 sub rndseed_CODE_64bit {
|
| my $courseseed=unpack("%32S*",$courseid.' '); |
my $courseseed=unpack("%32S*",$courseid.' '); |
| my $num1=$symbseed+$CODEchck; |
my $num1=$symbseed+$CODEchck; |
| my $num2=$CODEseed+$courseseed+$symbchck; |
my $num2=$CODEseed+$courseseed+$symbchck; |
| #&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck"); |
#&logthis("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck"); |
| #&Apache::lonxml::debug("rndseed :$num1:$num2:$symb"); |
#&logthis("rndseed :$num1:$num2:$symb"); |
| if ($_64bit) { $num1=(($num1<<32)>>32); } |
if ($_64bit) { $num1=(($num1<<32)>>32); } |
| if ($_64bit) { $num2=(($num2<<32)>>32); } |
if ($_64bit) { $num2=(($num2<<32)>>32); } |
| return "$num1:$num2"; |
return "$num1:$num2"; |
|
Line 6684 sub rndseed_CODE_64bit4 {
|
Line 6723 sub rndseed_CODE_64bit4 {
|
| my $courseseed=unpack("%32S*",$courseid.' '); |
my $courseseed=unpack("%32S*",$courseid.' '); |
| my $num1=$symbseed+$CODEchck; |
my $num1=$symbseed+$CODEchck; |
| my $num2=$CODEseed+$courseseed+$symbchck; |
my $num2=$CODEseed+$courseseed+$symbchck; |
| #&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck"); |
#&logthis("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck"); |
| #&Apache::lonxml::debug("rndseed :$num1:$num2:$symb"); |
#&logthis("rndseed :$num1:$num2:$symb"); |
| if ($_64bit) { $num1=(($num1<<32)>>32); } |
if ($_64bit) { $num1=(($num1<<32)>>32); } |
| if ($_64bit) { $num2=(($num2<<32)>>32); } |
if ($_64bit) { $num2=(($num2<<32)>>32); } |
| return "$num1:$num2"; |
return "$num1:$num2"; |
|
Line 6746 sub ireceipt {
|
Line 6785 sub ireceipt {
|
| my $return =&recprefix($fucourseid).'-'; |
my $return =&recprefix($fucourseid).'-'; |
| if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' || |
if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' || |
| $env{'request.state'} eq 'construct') { |
$env{'request.state'} eq 'construct') { |
| &Apache::lonxml::debug("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname). |
#&logthis("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname)." and ".($cpart%$cudom)); |
| " and ".($cpart%$cudom)); |
|
| |
|
| $return.= ($cunique%$cuname+ |
$return.= ($cunique%$cuname+ |
| $cunique%$cudom+ |
$cunique%$cudom+ |
|
Line 6770 sub ireceipt {
|
Line 6808 sub ireceipt {
|
| |
|
| sub receipt { |
sub receipt { |
| my ($part)=@_; |
my ($part)=@_; |
| my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser(); |
my ($symb,$courseid,$domain,$name) = &whichuser(); |
| return &ireceipt($name,$domain,$courseid,$symb,$part); |
return &ireceipt($name,$domain,$courseid,$symb,$part); |
| } |
} |
| |
|
| |
sub whichuser { |
| |
my ($passedsymb)=@_; |
| |
my ($symb,$courseid,$domain,$name,$publicuser); |
| |
if (defined($env{'form.grade_symb'})) { |
| |
my ($tmp_courseid)=&get_env_multiple('form.grade_courseid'); |
| |
my $allowed=&allowed('vgr',$tmp_courseid); |
| |
if (!$allowed && |
| |
exists($env{'request.course.sec'}) && |
| |
$env{'request.course.sec'} !~ /^\s*$/) { |
| |
$allowed=&allowed('vgr',$tmp_courseid. |
| |
'/'.$env{'request.course.sec'}); |
| |
} |
| |
if ($allowed) { |
| |
($symb)=&get_env_multiple('form.grade_symb'); |
| |
$courseid=$tmp_courseid; |
| |
($domain)=&get_env_multiple('form.grade_domain'); |
| |
($name)=&get_env_multiple('form.grade_username'); |
| |
return ($symb,$courseid,$domain,$name,$publicuser); |
| |
} |
| |
} |
| |
if (!$passedsymb) { |
| |
$symb=&symbread(); |
| |
} else { |
| |
$symb=$passedsymb; |
| |
} |
| |
$courseid=$env{'request.course.id'}; |
| |
$domain=$env{'user.domain'}; |
| |
$name=$env{'user.name'}; |
| |
if ($name eq 'public' && $domain eq 'public') { |
| |
if (!defined($env{'form.username'})) { |
| |
$env{'form.username'}.=time.rand(10000000); |
| |
} |
| |
$name.=$env{'form.username'}; |
| |
} |
| |
return ($symb,$courseid,$domain,$name,$publicuser); |
| |
|
| |
} |
| |
|
| # ------------------------------------------------------------ Serves up a file |
# ------------------------------------------------------------ Serves up a file |
| # returns either the contents of the file or |
# returns either the contents of the file or |
| # -1 if the file doesn't exist |
# -1 if the file doesn't exist |
|
Line 7036 sub clutter {
|
Line 7112 sub clutter {
|
| return $thisfn; |
return $thisfn; |
| } |
} |
| |
|
| |
sub clutter_with_no_wrapper { |
| |
my $uri = &clutter(shift); |
| |
if ($uri =~ m-^/adm/-) { |
| |
$uri =~ s-^/adm/wrapper/-/-; |
| |
$uri =~ s-^/adm/coursedocs/showdoc/-/-; |
| |
} |
| |
return $uri; |
| |
} |
| |
|
| sub freeze_escape { |
sub freeze_escape { |
| my ($value)=@_; |
my ($value)=@_; |
| if (ref($value)) { |
if (ref($value)) { |
|
Line 7088 BEGIN {
|
Line 7173 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 |
my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf'); |
| open(my $config,"</etc/httpd/conf/loncapa.conf"); |
%perlvar = (%perlvar,%{$configvars}); |
| |
|
| while (my $configline=<$config>) { |
|
| if ($configline=~/\S/ && $configline =~ /^[^\#]*PerlSetVar/) { |
|
| my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); |
|
| chomp($varvalue); |
|
| $perlvar{$varname}=$varvalue; |
|
| } |
|
| } |
|
| close($config); |
|
| } |
|
| { |
|
| open(my $config,"</etc/httpd/conf/loncapa_apache.conf"); |
|
| |
|
| while (my $configline=<$config>) { |
|
| if ($configline =~ /^[^\#]*PerlSetVar/) { |
|
| my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); |
|
| chomp($varvalue); |
|
| $perlvar{$varname}=$varvalue; |
|
| } |
|
| } |
|
| close($config); |
|
| } |
} |
| |
|
| # ------------------------------------------------------------ Read domain file |
# ------------------------------------------------------------ Read domain file |
|
Line 7192 sub get_iphost {
|
Line 7256 sub get_iphost {
|
| while (my $configline=<$config>) { |
while (my $configline=<$config>) { |
| chomp($configline); |
chomp($configline); |
| if ($configline) { |
if ($configline) { |
| $spareid{$configline}=1; |
my ($host,$type) = split(':',$configline,2); |
| |
if (!defined($type) || $type eq '') { $type = 'default' }; |
| |
push(@{ $spareid{$type} }, $host); |
| } |
} |
| } |
} |
| close($config); |
close($config); |
![[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