version 1.1056.4.28, 2011/07/28 18:30:16
|
version 1.1056.4.33.2.2, 2012/02/08 01:05:20
|
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 635 sub appenv {
|
Line 636 sub appenv {
|
# ----------------------------------------------------- Delete from Environment |
# ----------------------------------------------------- Delete from Environment |
|
|
sub delenv { |
sub delenv { |
my ($delthis,$regexp) = @_; |
my ($delthis,$regexp,$roles) = @_; |
if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) { |
if (($delthis=~/^user\.role/) || ($delthis=~/^user\.priv/)) { |
&logthis("<font color=\"blue\">WARNING: ". |
my $refused = 1; |
"Attempt to delete from environment ".$delthis); |
if (ref($roles) eq 'ARRAY') { |
return 'error'; |
my ($type,$role) = ($delthis =~ /^user\.(role|priv)\.([^.]+)\./); |
|
if (grep(/^\Q$role\E$/,@{$roles})) { |
|
$refused = 0; |
|
} |
|
} |
|
if ($refused) { |
|
&logthis("<font color=\"blue\">WARNING: ". |
|
"Attempt to delete from environment ".$delthis); |
|
return 'error'; |
|
} |
} |
} |
my $opened = open(my $env_file,'+<',$env{'user.environment'}); |
my $opened = open(my $env_file,'+<',$env{'user.environment'}); |
if ($opened |
if ($opened |
Line 831 sub compare_server_load {
|
Line 841 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; #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 877 sub has_user_session {
|
Line 887 sub has_user_session {
|
# --------- determine least loaded server in a user's domain which allows login |
# --------- determine least loaded server in a user's domain which allows login |
|
|
sub choose_server { |
sub choose_server { |
my ($udom) = @_; |
my ($udom,$checkloginvia) = @_; |
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); |
my ($login_host,$hostname,$portal_path,$isredirect); |
foreach my $lonhost (keys(%servers)) { |
foreach my $lonhost (keys(%servers)) { |
my $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost}; |
my $loginvia; |
if ($loginvia eq '') { |
if ($checkloginvia) { |
|
$loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost}; |
|
if ($loginvia) { |
|
my ($server,$path) = split(/:/,$loginvia); |
|
($login_host, $lowest_load) = |
|
&compare_server_load($lonhost, $login_host, $lowest_load); |
|
if ($login_host eq $server) { |
|
$portal_path = $path; |
|
$isredirect = 1; |
|
} |
|
} else { |
|
($login_host, $lowest_load) = |
|
&compare_server_load($lonhost, $login_host, $lowest_load); |
|
if ($login_host eq $lonhost) { |
|
$portal_path = ''; |
|
$isredirect = ''; |
|
} |
|
} |
|
} 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 ne '') { |
if ($login_host ne '') { |
$hostname = $servers{$login_host}; |
$hostname = &hostname($login_host); |
} |
} |
return ($login_host,$hostname); |
return ($login_host,$hostname,$portal_path,$isredirect); |
} |
} |
|
|
# --------------------------------------------- Try to change a user's password |
# --------------------------------------------- Try to change a user's password |
Line 1559 sub get_domain_defaults {
|
Line 1587 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 3205 sub get_my_roles {
|
Line 3234 sub get_my_roles {
|
if (!grep(/^cr$/,@{$roles})) { |
if (!grep(/^cr$/,@{$roles})) { |
next; |
next; |
} |
} |
|
} elsif ($role =~ /^gr\//) { |
|
if (!grep(/^gr$/,@{$roles})) { |
|
next; |
|
} |
} else { |
} else { |
next; |
next; |
} |
} |
Line 3698 sub hashref2str {
|
Line 3731 sub hashref2str {
|
$result.='='; |
$result.='='; |
#print("Got a ref of ".(ref($key))." skipping."); |
#print("Got a ref of ".(ref($key))." skipping."); |
} else { |
} else { |
if ($key) {$result.=&escape($key).'=';} else { last; } |
if (defined($key)) {$result.=&escape($key).'=';} else { last; } |
} |
} |
|
|
if(ref($hashref->{$key}) eq 'ARRAY') { |
if(ref($hashref->{$key}) eq 'ARRAY') { |
Line 4217 sub rolesinit {
|
Line 4250 sub rolesinit {
|
} |
} |
my %allroles=(); |
my %allroles=(); |
my %allgroups=(); |
my %allgroups=(); |
my $group_privs; |
|
|
|
if ($rolesdump ne '') { |
if ($rolesdump ne '') { |
foreach my $entry (split(/&/,$rolesdump)) { |
foreach my $entry (split(/&/,$rolesdump)) { |
Line 4234 sub rolesinit {
|
Line 4266 sub rolesinit {
|
} |
} |
} elsif ($role =~ m|^gr/|) { |
} elsif ($role =~ m|^gr/|) { |
($trole,$tend,$tstart) = split(/_/,$role); |
($trole,$tend,$tstart) = split(/_/,$role); |
|
next if ($tstart eq '-1'); |
($trole,$group_privs) = split(/\//,$trole); |
($trole,$group_privs) = split(/\//,$trole); |
$group_privs = &unescape($group_privs); |
$group_privs = &unescape($group_privs); |
} else { |
} else { |
Line 4386 sub set_userprivs {
|
Line 4419 sub set_userprivs {
|
} |
} |
} |
} |
my $thesestr=''; |
my $thesestr=''; |
foreach my $priv (keys(%thesepriv)) { |
foreach my $priv (sort(keys(%thesepriv))) { |
$thesestr.=':'.$priv.'&'.$thesepriv{$priv}; |
$thesestr.=':'.$priv.'&'.$thesepriv{$priv}; |
} |
} |
$userroles->{'user.priv.'.$role} = $thesestr; |
$userroles->{'user.priv.'.$role} = $thesestr; |
Line 4395 sub set_userprivs {
|
Line 4428 sub set_userprivs {
|
} |
} |
|
|
sub role_status { |
sub role_status { |
my ($rolekey,$then,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_; |
my ($rolekey,$update,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_; |
my @pwhere = (); |
my @pwhere = (); |
if (exists($env{$rolekey}) && $env{$rolekey} ne '') { |
if (exists($env{$rolekey}) && $env{$rolekey} ne '') { |
(undef,undef,$$role,@pwhere)=split(/\./,$rolekey); |
(undef,undef,$$role,@pwhere)=split(/\./,$rolekey); |
Line 4404 sub role_status {
|
Line 4437 sub role_status {
|
$$trolecode=$$role.'.'.$$where; |
$$trolecode=$$role.'.'.$$where; |
($$tstart,$$tend)=split(/\./,$env{$rolekey}); |
($$tstart,$$tend)=split(/\./,$env{$rolekey}); |
$$tstatus='is'; |
$$tstatus='is'; |
if ($$tstart && $$tstart>$then) { |
if ($$tstart && $$tstart>$update) { |
$$tstatus='future'; |
$$tstatus='future'; |
if ($$tstart<$now) { |
if ($$tstart<$now) { |
if ($$tstart && $$tstart>$refresh) { |
if ($$tstart && $$tstart>$refresh) { |
Line 4429 sub role_status {
|
Line 4462 sub role_status {
|
$group_privs = &unescape($group_privs); |
$group_privs = &unescape($group_privs); |
&group_roleprivs(\%allgroups,$$where,$group_privs,$$tend,$$tstart); |
&group_roleprivs(\%allgroups,$$where,$group_privs,$$tend,$$tstart); |
my %course_roles = &get_my_roles($env{'user.name'},$env{'user.domain'},'userroles',['active'],['cc','co','in','ta','ep','ad','st','cr'],[$tdomain],1); |
my %course_roles = &get_my_roles($env{'user.name'},$env{'user.domain'},'userroles',['active'],['cc','co','in','ta','ep','ad','st','cr'],[$tdomain],1); |
if (keys(%course_roles) > 0) { |
&get_groups_roles($tdomain,$trest, |
my ($tnum) = ($trest =~ /^($match_courseid)/); |
\%course_roles,\@rolecodes, |
if ($tdomain ne '' && $tnum ne '') { |
\%groups_roles); |
foreach my $key (keys(%course_roles)) { |
|
if ($key =~ /^\Q$tnum\E:\Q$tdomain\E:([^:]+):?([^:]*)/) { |
|
my $crsrole = $1; |
|
my $crssec = $2; |
|
if ($crsrole =~ /^cr/) { |
|
unless (grep(/^cr$/,@rolecodes)) { |
|
push(@rolecodes,'cr'); |
|
} |
|
} else { |
|
unless(grep(/^\Q$crsrole\E$/,@rolecodes)) { |
|
push(@rolecodes,$crsrole); |
|
} |
|
} |
|
my $rolekey = $crsrole.'./'.$tdomain.'/'.$tnum; |
|
if ($crssec ne '') { |
|
$rolekey .= '/'.$crssec; |
|
} |
|
$rolekey .= './'; |
|
$groups_roles{$rolekey} = \@rolecodes; |
|
} |
|
} |
|
} |
|
} |
|
} else { |
} else { |
push(@rolecodes,$$role); |
push(@rolecodes,$$role); |
&standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where); |
&standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where); |
Line 4468 sub role_status {
|
Line 4478 sub role_status {
|
} |
} |
} |
} |
if ($$tend) { |
if ($$tend) { |
if ($$tend<$then) { |
if ($$tend<$update) { |
$$tstatus='expired'; |
$$tstatus='expired'; |
} elsif ($$tend<$now) { |
} elsif ($$tend<$now) { |
$$tstatus='will_not'; |
$$tstatus='will_not'; |
Line 4478 sub role_status {
|
Line 4488 sub role_status {
|
} |
} |
} |
} |
|
|
|
sub get_groups_roles { |
|
my ($cdom,$rest,$cdom_courseroles,$rolecodes,$groups_roles) = @_; |
|
return unless((ref($cdom_courseroles) eq 'HASH') && |
|
(ref($rolecodes) eq 'ARRAY') && |
|
(ref($groups_roles) eq 'HASH')); |
|
if (keys(%{$cdom_courseroles}) > 0) { |
|
my ($cnum) = ($rest =~ /^($match_courseid)/); |
|
if ($cdom ne '' && $cnum ne '') { |
|
foreach my $key (keys(%{$cdom_courseroles})) { |
|
if ($key =~ /^\Q$cnum\E:\Q$cdom\E:([^:]+):?([^:]*)/) { |
|
my $crsrole = $1; |
|
my $crssec = $2; |
|
if ($crsrole =~ /^cr/) { |
|
unless (grep(/^cr$/,@{$rolecodes})) { |
|
push(@{$rolecodes},'cr'); |
|
} |
|
} else { |
|
unless(grep(/^\Q$crsrole\E$/,@{$rolecodes})) { |
|
push(@{$rolecodes},$crsrole); |
|
} |
|
} |
|
my $rolekey = "$crsrole./$cdom/$cnum"; |
|
if ($crssec ne '') { |
|
$rolekey .= "/$crssec"; |
|
} |
|
$rolekey .= './'; |
|
$groups_roles->{$rolekey} = $rolecodes; |
|
} |
|
} |
|
} |
|
} |
|
return; |
|
} |
|
|
|
sub delete_env_groupprivs { |
|
my ($where,$courseroles,$possroles) = @_; |
|
return unless((ref($courseroles) eq 'HASH') && (ref($possroles) eq 'ARRAY')); |
|
my ($dummy,$udom,$uname,$group) = split(/\//,$where); |
|
unless (ref($courseroles->{$udom}) eq 'HASH') { |
|
%{$courseroles->{$udom}} = |
|
&get_my_roles('','','userroles',['active'], |
|
$possroles,[$udom],1); |
|
} |
|
if (ref($courseroles->{$udom}) eq 'HASH') { |
|
foreach my $item (keys(%{$courseroles->{$udom}})) { |
|
my ($cnum,$cdom,$crsrole,$crssec) = split(/:/,$item); |
|
my $area = '/'.$cdom.'/'.$cnum; |
|
my $privkey = "user.priv.$crsrole.$area"; |
|
if ($crssec ne '') { |
|
$privkey .= '/'.$crssec; |
|
} |
|
$privkey .= ".$area/$group"; |
|
&Apache::lonnet::delenv($privkey,undef,[$crsrole]); |
|
} |
|
} |
|
return; |
|
} |
|
|
sub check_adhoc_privs { |
sub check_adhoc_privs { |
my ($cdom,$cnum,$then,$refresh,$now,$checkrole,$caller) = @_; |
my ($cdom,$cnum,$update,$refresh,$now,$checkrole,$caller) = @_; |
my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum; |
my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum; |
if ($env{$cckey}) { |
if ($env{$cckey}) { |
my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend); |
my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend); |
&role_status($cckey,$then,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend); |
&role_status($cckey,$update,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend); |
unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) { |
unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) { |
&set_adhoc_privileges($cdom,$cnum,$checkrole,$caller); |
&set_adhoc_privileges($cdom,$cnum,$checkrole,$caller); |
} |
} |
Line 6732 sub assignrole {
|
Line 6800 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 10006 sub get_dns {
|
Line 10081 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 10521 BEGIN {
|
Line 10597 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 = $perlvar{'lonDaemons'}.'/tmp/'; |
Line 11414 splitting on '&', supports elements that
|
Line 11506 splitting on '&', supports elements that
|
|
|
=head2 Logging Routines |
=head2 Logging Routines |
|
|
=over 4 |
|
|
|
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. |
|
|
|
=over 4 |
|
|
=item * |
=item * |
|
|
logtouch() : make sure the logfile, lonnet.log, exists |
logtouch() : make sure the logfile, lonnet.log, exists |