|
version 1.1409, 2019/04/29 22:19:45
|
version 1.1441, 2021/02/08 14:10:17
|
|
Line 79 use Encode;
|
Line 79 use Encode;
|
| |
|
| use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $deftex |
use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $deftex |
| $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease |
$_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease |
| %managerstab); |
%managerstab $passwdmin); |
| |
|
| my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash, |
my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash, |
| %userrolehash, $processmarker, $dumpcount, %coursedombuf, |
%userrolehash, $processmarker, $dumpcount, %coursedombuf, |
|
Line 96 use Cache::Memcached;
|
Line 96 use Cache::Memcached;
|
| use Digest::MD5; |
use Digest::MD5; |
| use Math::Random; |
use Math::Random; |
| use File::MMagic; |
use File::MMagic; |
| |
use Net::CIDR; |
| use LONCAPA qw(:DEFAULT :match); |
use LONCAPA qw(:DEFAULT :match); |
| use LONCAPA::Configuration; |
use LONCAPA::Configuration; |
| use LONCAPA::lonmetadata; |
use LONCAPA::lonmetadata; |
|
Line 128 our @EXPORT = qw(%env);
|
Line 129 our @EXPORT = qw(%env);
|
| $logid ++; |
$logid ++; |
| my $now = time(); |
my $now = time(); |
| my $id=$now.'00000'.$$.'00000'.$logid; |
my $id=$now.'00000'.$$.'00000'.$logid; |
| |
my $ip = &get_requestor_ip(); |
| my $logentry = { |
my $logentry = { |
| $id => { |
$id => { |
| 'exe_uname' => $env{'user.name'}, |
'exe_uname' => $env{'user.name'}, |
| 'exe_udom' => $env{'user.domain'}, |
'exe_udom' => $env{'user.domain'}, |
| 'exe_time' => $now, |
'exe_time' => $now, |
| 'exe_ip' => $ENV{'REMOTE_ADDR'}, |
'exe_ip' => $ip, |
| 'delflag' => $delflag, |
'delflag' => $delflag, |
| 'logentry' => $storehash, |
'logentry' => $storehash, |
| 'uname' => $uname, |
'uname' => $uname, |
|
Line 1082 sub find_existing_session {
|
Line 1084 sub find_existing_session {
|
| return; |
return; |
| } |
} |
| |
|
| |
sub delusersession { |
| |
my ($lonid,$udom,$uname) = @_; |
| |
my $uprimary_id = &domain($udom,'primary'); |
| |
my $uintdom = &internet_dom($uprimary_id); |
| |
my $intdom = &internet_dom($lonid); |
| |
my $serverhomedom = &host_domain($lonid); |
| |
if (($uintdom ne '') && ($uintdom eq $intdom)) { |
| |
return &reply(join(':','delusersession', |
| |
map {&escape($_)} ($udom,$uname)),$lonid); |
| |
} |
| |
return; |
| |
} |
| |
|
| # check if user's browser sent load balancer cookie and server still has session |
# check if user's browser sent load balancer cookie and server still has session |
| # and is not overloaded. |
# and is not overloaded. |
| sub check_for_balancer_cookie { |
sub check_for_balancer_cookie { |
|
Line 1137 sub check_for_balancer_cookie {
|
Line 1152 sub check_for_balancer_cookie {
|
| return ($otherserver,$cookie); |
return ($otherserver,$cookie); |
| } |
} |
| |
|
| |
sub updatebalcookie { |
| |
my ($cookie,$balancer,$lastentry)=@_; |
| |
if ($cookie =~ /^($match_domain)\_($match_username)\_[a-f0-9]{32}$/) { |
| |
my ($udom,$uname) = ($1,$2); |
| |
my $uprimary_id = &domain($udom,'primary'); |
| |
my $uintdom = &internet_dom($uprimary_id); |
| |
my $intdom = &internet_dom($balancer); |
| |
my $serverhomedom = &host_domain($balancer); |
| |
if (($uintdom ne '') && ($uintdom eq $intdom)) { |
| |
return &reply('updatebalcookie:'.&escape($cookie).':'.&escape($lastentry),$balancer); |
| |
} |
| |
} |
| |
return; |
| |
} |
| |
|
| sub delbalcookie { |
sub delbalcookie { |
| my ($cookie,$balancer) =@_; |
my ($cookie,$balancer) =@_; |
| if ($cookie =~ /^($match_domain)\_($match_username)\_[a-f0-9]{32}$/) { |
if ($cookie =~ /^($match_domain)\_($match_username)\_[a-f0-9]{32}$/) { |
|
Line 1146 sub delbalcookie {
|
Line 1176 sub delbalcookie {
|
| my $intdom = &internet_dom($balancer); |
my $intdom = &internet_dom($balancer); |
| my $serverhomedom = &host_domain($balancer); |
my $serverhomedom = &host_domain($balancer); |
| if (($uintdom ne '') && ($uintdom eq $intdom)) { |
if (($uintdom ne '') && ($uintdom eq $intdom)) { |
| return &reply("delbalcookie:$cookie",$balancer); |
return &reply('delbalcookie:'.&escape($cookie),$balancer); |
| } |
} |
| } |
} |
| } |
} |
|
Line 1217 sub choose_server {
|
Line 1247 sub choose_server {
|
| return ($login_host,$hostname,$portal_path,$isredirect,$lowest_load); |
return ($login_host,$hostname,$portal_path,$isredirect,$lowest_load); |
| } |
} |
| |
|
| |
sub get_course_sessions { |
| |
my ($cnum,$cdom,$lastactivity) = @_; |
| |
my %servers = &internet_dom_servers($cdom); |
| |
my %returnhash; |
| |
foreach my $server (sort(keys(%servers))) { |
| |
my $rep = &reply("coursesessions:$cdom:$cnum:$lastactivity",$server); |
| |
my @pairs=split(/\&/,$rep); |
| |
unless (($rep eq 'unknown_cmd') || ($rep =~ /^error/)) { |
| |
foreach my $item (@pairs) { |
| |
my ($key,$value)=split(/=/,$item,2); |
| |
$key = &unescape($key); |
| |
next if ($key =~ /^error: 2 /); |
| |
if (exists($returnhash{$key})) { |
| |
next if ($value < $returnhash{$key}); |
| |
} |
| |
$returnhash{$key}=$value; |
| |
} |
| |
} |
| |
} |
| |
return %returnhash; |
| |
} |
| |
|
| # --------------------------------------------- Try to change a user's password |
# --------------------------------------------- Try to change a user's password |
| |
|
| sub changepass { |
sub changepass { |
|
Line 1393 sub spare_can_host {
|
Line 1445 sub spare_can_host {
|
| $canhost = 0; |
$canhost = 0; |
| } |
} |
| } |
} |
| |
if ($canhost) { |
| |
if (ref($defdomdefaults{'offloadoth'}) eq 'HASH') { |
| |
if ($defdomdefaults{'offloadoth'}{$try_server}) { |
| |
unless (&shared_institution($udom,$try_server)) { |
| |
$canhost = 0; |
| |
} |
| |
} |
| |
} |
| |
} |
| if (($canhost) && ($uint_dom)) { |
if (($canhost) && ($uint_dom)) { |
| my @intdoms; |
my @intdoms; |
| my $internet_names = &get_internet_names($try_server); |
my $internet_names = &get_internet_names($try_server); |
|
Line 1611 sub check_loadbalancing {
|
Line 1672 sub check_loadbalancing {
|
| if ($domneedscache) { |
if ($domneedscache) { |
| &do_cache_new('loadbalancing',$domneedscache,$is_balancer,$cachetime); |
&do_cache_new('loadbalancing',$domneedscache,$is_balancer,$cachetime); |
| } |
} |
| if ($is_balancer) { |
if (($is_balancer) && ($caller ne 'switchserver')) { |
| my $lowest_load = 30000; |
my $lowest_load = 30000; |
| if (ref($offloadto) eq 'HASH') { |
if (ref($offloadto) eq 'HASH') { |
| if (ref($offloadto->{'primary'}) eq 'ARRAY') { |
if (ref($offloadto->{'primary'}) eq 'ARRAY') { |
|
Line 1651 sub check_loadbalancing {
|
Line 1712 sub check_loadbalancing {
|
| } |
} |
| } |
} |
| } |
} |
| unless ($homeintdom) { |
} |
| undef($setcookie); |
if (($is_balancer) && (!$homeintdom)) { |
| } |
undef($setcookie); |
| } |
} |
| return ($is_balancer,$otherserver,$setcookie,$offloadto,$dom_balancers); |
return ($is_balancer,$otherserver,$setcookie,$offloadto,$dom_balancers); |
| } |
} |
|
Line 2248 sub inst_directory_query {
|
Line 2309 sub inst_directory_query {
|
| if ($homeserver ne '') { |
if ($homeserver ne '') { |
| unless ($homeserver eq $perlvar{'lonHostID'}) { |
unless ($homeserver eq $perlvar{'lonHostID'}) { |
| if ($srch->{'srchby'} eq 'email') { |
if ($srch->{'srchby'} eq 'email') { |
| my $lcrev = &get_server_loncaparev(undef,$homeserver); |
my $lcrev = &get_server_loncaparev($udom,$homeserver); |
| my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/); |
my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/); |
| if (($major eq '' && $minor eq '') || ($major < 2) || |
if (($major eq '' && $minor eq '') || ($major < 2) || |
| (($major == 2) && ($minor < 12))) { |
(($major == 2) && ($minor < 12))) { |
|
Line 2299 sub usersearch {
|
Line 2360 sub usersearch {
|
| if (&host_domain($tryserver) eq $dom) { |
if (&host_domain($tryserver) eq $dom) { |
| unless ($tryserver eq $perlvar{'lonHostID'}) { |
unless ($tryserver eq $perlvar{'lonHostID'}) { |
| if ($srch->{'srchby'} eq 'email') { |
if ($srch->{'srchby'} eq 'email') { |
| my $lcrev = &get_server_loncaparev(undef,$tryserver); |
my $lcrev = &get_server_loncaparev($dom,$tryserver); |
| my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/); |
my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/); |
| next if (($major eq '' && $minor eq '') || ($major < 2) || |
next if (($major eq '' && $minor eq '') || ($major < 2) || |
| (($major == 2) && ($minor < 12))); |
(($major == 2) && ($minor < 12))); |
|
Line 2544 sub get_domain_defaults {
|
Line 2605 sub get_domain_defaults {
|
| 'coursedefaults','usersessions', |
'coursedefaults','usersessions', |
| 'requestauthor','selfenrollment', |
'requestauthor','selfenrollment', |
| 'coursecategories','ssl','autoenroll', |
'coursecategories','ssl','autoenroll', |
| 'trust','helpsettings'],$domain); |
'trust','helpsettings','wafproxy'],$domain); |
| my @coursetypes = ('official','unofficial','community','textbook','placement'); |
my @coursetypes = ('official','unofficial','community','textbook','placement'); |
| if (ref($domconfig{'defaults'}) eq 'HASH') { |
if (ref($domconfig{'defaults'}) eq 'HASH') { |
| $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; |
$domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; |
|
Line 2637 sub get_domain_defaults {
|
Line 2698 sub get_domain_defaults {
|
| if (ref($domconfig{'usersessions'}{'offloadnow'}) eq 'HASH') { |
if (ref($domconfig{'usersessions'}{'offloadnow'}) eq 'HASH') { |
| $domdefaults{'offloadnow'} = $domconfig{'usersessions'}{'offloadnow'}; |
$domdefaults{'offloadnow'} = $domconfig{'usersessions'}{'offloadnow'}; |
| } |
} |
| |
if (ref($domconfig{'usersessions'}{'offloadoth'}) eq 'HASH') { |
| |
$domdefaults{'offloadoth'} = $domconfig{'usersessions'}{'offloadoth'}; |
| |
} |
| } |
} |
| if (ref($domconfig{'selfenrollment'}) eq 'HASH') { |
if (ref($domconfig{'selfenrollment'}) eq 'HASH') { |
| if (ref($domconfig{'selfenrollment'}{'admin'}) eq 'HASH') { |
if (ref($domconfig{'selfenrollment'}{'admin'}) eq 'HASH') { |
|
Line 2669 sub get_domain_defaults {
|
Line 2733 sub get_domain_defaults {
|
| if (ref($domconfig{'coursecategories'}) eq 'HASH') { |
if (ref($domconfig{'coursecategories'}) eq 'HASH') { |
| $domdefaults{'catauth'} = 'std'; |
$domdefaults{'catauth'} = 'std'; |
| $domdefaults{'catunauth'} = 'std'; |
$domdefaults{'catunauth'} = 'std'; |
| if ($domconfig{'coursecategories'}{'auth'}) { |
if ($domconfig{'coursecategories'}{'auth'}) { |
| $domdefaults{'catauth'} = $domconfig{'coursecategories'}{'auth'}; |
$domdefaults{'catauth'} = $domconfig{'coursecategories'}{'auth'}; |
| } |
} |
| if ($domconfig{'coursecategories'}{'unauth'}) { |
if ($domconfig{'coursecategories'}{'unauth'}) { |
|
Line 2704 sub get_domain_defaults {
|
Line 2768 sub get_domain_defaults {
|
| $domdefaults{'adhocroles'} = $domconfig{'helpsettings'}{'adhoc'}; |
$domdefaults{'adhocroles'} = $domconfig{'helpsettings'}{'adhoc'}; |
| } |
} |
| } |
} |
| |
if (ref($domconfig{'wafproxy'}) eq 'HASH') { |
| |
foreach my $item ('ipheader','trusted','vpnint','vpnext') { |
| |
if ($domconfig{'wafproxy'}{$item}) { |
| |
$domdefaults{'waf_'.$item} = $domconfig{'wafproxy'}{$item}; |
| |
} |
| |
} |
| |
} |
| &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime); |
&do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime); |
| return %domdefaults; |
return %domdefaults; |
| } |
} |
| |
|
| |
sub get_dom_cats { |
| |
my ($dom) = @_; |
| |
return unless (&domain($dom)); |
| |
my ($cats,$cached)=&is_cached_new('cats',$dom); |
| |
unless (defined($cached)) { |
| |
my %domconfig = &get_dom('configuration',['coursecategories'],$dom); |
| |
if (ref($domconfig{'coursecategories'}) eq 'HASH') { |
| |
if (ref($domconfig{'coursecategories'}{'cats'}) eq 'HASH') { |
| |
%{$cats} = %{$domconfig{'coursecategories'}{'cats'}}; |
| |
} else { |
| |
$cats = {}; |
| |
} |
| |
} else { |
| |
$cats = {}; |
| |
} |
| |
&Apache::lonnet::do_cache_new('cats',$dom,$cats,3600); |
| |
} |
| |
return $cats; |
| |
} |
| |
|
| |
sub get_dom_instcats { |
| |
my ($dom) = @_; |
| |
return unless (&domain($dom)); |
| |
my ($instcats,$cached)=&is_cached_new('instcats',$dom); |
| |
unless (defined($cached)) { |
| |
my (%coursecodes,%codes,@codetitles,%cat_titles,%cat_order); |
| |
my $totcodes = &retrieve_instcodes(\%coursecodes,$dom); |
| |
if ($totcodes > 0) { |
| |
my $caller = 'global'; |
| |
if (&auto_instcode_format($caller,$dom,\%coursecodes,\%codes, |
| |
\@codetitles,\%cat_titles,\%cat_order) eq 'ok') { |
| |
$instcats = { |
| |
codes => \%codes, |
| |
codetitles => \@codetitles, |
| |
cat_titles => \%cat_titles, |
| |
cat_order => \%cat_order, |
| |
}; |
| |
&do_cache_new('instcats',$dom,$instcats,3600); |
| |
} |
| |
} |
| |
} |
| |
return $instcats; |
| |
} |
| |
|
| |
sub retrieve_instcodes { |
| |
my ($coursecodes,$dom) = @_; |
| |
my $totcodes; |
| |
my %courses = &courseiddump($dom,'.',1,'.','.','.',undef,undef,'Course'); |
| |
foreach my $course (keys(%courses)) { |
| |
if (ref($courses{$course}) eq 'HASH') { |
| |
if ($courses{$course}{'inst_code'} ne '') { |
| |
$$coursecodes{$course} = $courses{$course}{'inst_code'}; |
| |
$totcodes ++; |
| |
} |
| |
} |
| |
} |
| |
return $totcodes; |
| |
} |
| |
|
| sub course_portal_url { |
sub course_portal_url { |
| my ($cnum,$cdom) = @_; |
my ($cnum,$cdom) = @_; |
| my $chome = &homeserver($cnum,$cdom); |
my $chome = &homeserver($cnum,$cdom); |
|
Line 3289 sub repcopy {
|
Line 3419 sub repcopy {
|
| } |
} |
| } |
} |
| |
|
| |
# ------------------------------------------------- Unsubscribe from a resource |
| |
|
| |
sub unsubscribe { |
| |
my ($fname) = @_; |
| |
my $answer; |
| |
if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return $answer; } |
| |
$fname=~s/[\n\r]//g; |
| |
my $author=$fname; |
| |
$author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; |
| |
my ($udom,$uname)=split(/\//,$author); |
| |
my $home=homeserver($uname,$udom); |
| |
if ($home eq 'no_host') { |
| |
$answer = 'no_host'; |
| |
} elsif (grep { $_ eq $home } ¤t_machine_ids()) { |
| |
$answer = 'home'; |
| |
} else { |
| |
my $defdom = $perlvar{'lonDefDomain'}; |
| |
if (&will_trust('content',$defdom,$udom)) { |
| |
$answer = reply("unsub:$fname",$home); |
| |
} else { |
| |
$answer = 'untrusted'; |
| |
} |
| |
} |
| |
return $answer; |
| |
} |
| |
|
| # ------------------------------------------------ Get server side include body |
# ------------------------------------------------ Get server side include body |
| sub ssi_body { |
sub ssi_body { |
| my ($filelink,%form)=@_; |
my ($filelink,%form)=@_; |
|
Line 3434 sub remove_stale_resfile {
|
Line 3590 sub remove_stale_resfile {
|
| $stale = 1; |
$stale = 1; |
| } |
} |
| if ($stale) { |
if ($stale) { |
| unlink($fname); |
if (unlink($fname)) { |
| if ($uri!~/\.meta$/) { |
if ($uri!~/\.meta$/) { |
| unlink($fname.'.meta'); |
if (-e $fname.'.meta') { |
| |
unlink($fname.'.meta'); |
| |
} |
| |
} |
| |
my $unsubresult = &unsubscribe($fname); |
| |
unless ($unsubresult eq 'ok') { |
| |
&logthis("no unsub of $fname from $homeserver, reason: $unsubresult"); |
| |
} |
| |
$removed = 1; |
| } |
} |
| &reply("unsub:$fname",$homeserver); |
|
| $removed = 1; |
|
| } |
} |
| } |
} |
| } |
} |
|
Line 3589 sub can_edit_resource {
|
Line 3751 sub can_edit_resource {
|
| $forceedit = 1; |
$forceedit = 1; |
| } |
} |
| $cfile = $resurl; |
$cfile = $resurl; |
| |
} elsif (($resurl =~ m{^/ext/}) && ($symb ne '')) { |
| |
my ($map,$id,$res) = &decode_symb($symb); |
| |
if ($map =~ /\.page$/) { |
| |
$incourse = 1; |
| |
if ($env{'form.forceedit'}) { |
| |
$forceview = 1; |
| |
$cfile = $map; |
| |
} else { |
| |
$forceedit = 1; |
| |
$cfile = '/adm/wrapper'.$resurl; |
| |
} |
| |
} |
| } elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) { |
} elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) { |
| $incourse = 1; |
$incourse = 1; |
| if ($env{'form.forceedit'}) { |
if ($env{'form.forceedit'}) { |
|
Line 3614 sub can_edit_resource {
|
Line 3788 sub can_edit_resource {
|
| $cfile = $template; |
$cfile = $template; |
| } |
} |
| } elsif (($resurl =~ m{^/adm/wrapper/ext/}) && ($env{'form.folderpath'} =~ /^supplemental/)) { |
} elsif (($resurl =~ m{^/adm/wrapper/ext/}) && ($env{'form.folderpath'} =~ /^supplemental/)) { |
| $incourse = 1; |
$incourse = 1; |
| if ($env{'form.forceedit'}) { |
if ($env{'form.forceedit'}) { |
| $forceview = 1; |
$forceview = 1; |
| } else { |
} else { |
| $forceedit = 1; |
$forceedit = 1; |
| } |
} |
| $cfile = $resurl; |
$cfile = $resurl; |
| } elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) && ($env{'form.folderpath'} =~ /^supplemental/)) { |
} elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) && ($env{'form.folderpath'} =~ /^supplemental/)) { |
| $incourse = 1; |
$incourse = 1; |
| if ($env{'form.forceedit'}) { |
if ($env{'form.forceedit'}) { |
|
Line 4861 sub courseacclog {
|
Line 5035 sub courseacclog {
|
| if ($formitem =~ /^HWFILE(?:SIZE|TOOBIG)/) { |
if ($formitem =~ /^HWFILE(?:SIZE|TOOBIG)/) { |
| $what.=':'.$formitem.'='.$env{$key}; |
$what.=':'.$formitem.'='.$env{$key}; |
| } elsif ($formitem !~ /^HWFILE(?:[^.]+)$/) { |
} elsif ($formitem !~ /^HWFILE(?:[^.]+)$/) { |
| $what.=':'.$formitem.'='.$env{$key}; |
if ($formitem eq 'proctorpassword') { |
| |
$what.=':'.$formitem.'=' . '*' x length($env{$key}); |
| |
} else { |
| |
$what.=':'.$formitem.'='.$env{$key}; |
| |
} |
| } |
} |
| } |
} |
| } |
} |
|
Line 5943 sub tmpreset {
|
Line 6121 sub tmpreset {
|
| if (!$domain) { $domain=$env{'user.domain'}; } |
if (!$domain) { $domain=$env{'user.domain'}; } |
| if (!$stuname) { $stuname=$env{'user.name'}; } |
if (!$stuname) { $stuname=$env{'user.name'}; } |
| if ($domain eq 'public' && $stuname eq 'public') { |
if ($domain eq 'public' && $stuname eq 'public') { |
| $stuname=$ENV{'REMOTE_ADDR'}; |
$stuname=&get_requestor_ip(); |
| } |
} |
| my $path=LONCAPA::tempdir(); |
my $path=LONCAPA::tempdir(); |
| my %hash; |
my %hash; |
|
Line 5980 sub tmpstore {
|
Line 6158 sub tmpstore {
|
| if (!$domain) { $domain=$env{'user.domain'}; } |
if (!$domain) { $domain=$env{'user.domain'}; } |
| if (!$stuname) { $stuname=$env{'user.name'}; } |
if (!$stuname) { $stuname=$env{'user.name'}; } |
| if ($domain eq 'public' && $stuname eq 'public') { |
if ($domain eq 'public' && $stuname eq 'public') { |
| $stuname=$ENV{'REMOTE_ADDR'}; |
$stuname=&get_requestor_ip(); |
| } |
} |
| my $now=time; |
my $now=time; |
| my %hash; |
my %hash; |
|
Line 6024 sub tmprestore {
|
Line 6202 sub tmprestore {
|
| if (!$domain) { $domain=$env{'user.domain'}; } |
if (!$domain) { $domain=$env{'user.domain'}; } |
| if (!$stuname) { $stuname=$env{'user.name'}; } |
if (!$stuname) { $stuname=$env{'user.name'}; } |
| if ($domain eq 'public' && $stuname eq 'public') { |
if ($domain eq 'public' && $stuname eq 'public') { |
| $stuname=$ENV{'REMOTE_ADDR'}; |
$stuname=&get_requestor_ip(); |
| } |
} |
| my %returnhash; |
my %returnhash; |
| $namespace=~s/\//\_/g; |
$namespace=~s/\//\_/g; |
|
Line 6080 sub store {
|
Line 6258 sub store {
|
| } |
} |
| if (!$home) { $home=$env{'user.home'}; } |
if (!$home) { $home=$env{'user.home'}; } |
| |
|
| $$storehash{'ip'}=$ENV{'REMOTE_ADDR'}; |
$$storehash{'ip'}=&get_requestor_ip(); |
| $$storehash{'host'}=$perlvar{'lonHostID'}; |
$$storehash{'host'}=$perlvar{'lonHostID'}; |
| |
|
| my $namevalue=''; |
my $namevalue=''; |
|
Line 6116 sub cstore {
|
Line 6294 sub cstore {
|
| } |
} |
| if (!$home) { $home=$env{'user.home'}; } |
if (!$home) { $home=$env{'user.home'}; } |
| |
|
| $$storehash{'ip'}=$ENV{'REMOTE_ADDR'}; |
$$storehash{'ip'}=&get_requestor_ip(); |
| $$storehash{'host'}=$perlvar{'lonHostID'}; |
$$storehash{'host'}=$perlvar{'lonHostID'}; |
| |
|
| my $namevalue=''; |
my $namevalue=''; |
|
Line 7111 sub putstore {
|
Line 7289 sub putstore {
|
| foreach my $key (keys(%{$storehash})) { |
foreach my $key (keys(%{$storehash})) { |
| $namevalue.=&escape($key).'='.&freeze_escape($storehash->{$key}).'&'; |
$namevalue.=&escape($key).'='.&freeze_escape($storehash->{$key}).'&'; |
| } |
} |
| $namevalue .= 'ip='.&escape($ENV{'REMOTE_ADDR'}). |
my $ip = &get_requestor_ip(); |
| |
$namevalue .= 'ip='.&escape($ip). |
| '&host='.&escape($perlvar{'lonHostID'}). |
'&host='.&escape($perlvar{'lonHostID'}). |
| '&version='.$esc_v. |
'&version='.$esc_v. |
| '&by='.&escape($env{'user.name'}.':'.$env{'user.domain'}); |
'&by='.&escape($env{'user.name'}.':'.$env{'user.domain'}); |
|
Line 7898 sub customaccess {
|
Line 8077 sub customaccess {
|
| # ------------------------------------------------- Check for a user privilege |
# ------------------------------------------------- Check for a user privilege |
| |
|
| sub allowed { |
sub allowed { |
| my ($priv,$uri,$symb,$role,$clientip,$noblockcheck)=@_; |
my ($priv,$uri,$symb,$role,$clientip,$noblockcheck,$ignorecache)=@_; |
| my $ver_orguri=$uri; |
my $ver_orguri=$uri; |
| $uri=&deversion($uri); |
$uri=&deversion($uri); |
| my $orguri=$uri; |
my $orguri=$uri; |
|
Line 7915 sub allowed {
|
Line 8094 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{/(?:smppg|bulletinboard|ext\.tool)$})) |
if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard|viewclasslist|aboutme|ext\.tool)$})) |
| || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) |
|| (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) |
| && ($priv eq 'bre')) { |
&& ($priv eq 'bre')) { |
| return 'F'; |
return 'F'; |
|
Line 8089 sub allowed {
|
Line 8268 sub allowed {
|
| ($env{'course.'.$env{'request.course.id'}.'.internal.courseowner'} eq $env{'user.name'}.':'.$env{'user.domain'})) { |
($env{'course.'.$env{'request.course.id'}.'.internal.courseowner'} eq $env{'user.name'}.':'.$env{'user.domain'})) { |
| my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; |
my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; |
| if ($cdom ne '') { |
if ($cdom ne '') { |
| my %passwdconf = &Apache::lonnet::get_passwdconf($cdom); |
my %passwdconf = &get_passwdconf($cdom); |
| if ($passwdconf{'crsownerchg'}) { |
if (ref($passwdconf{'crsownerchg'}) eq 'HASH') { |
| $thisallowed.=$rem; |
if (ref($passwdconf{'crsownerchg'}{'by'}) eq 'ARRAY') { |
| |
if (@{$passwdconf{'crsownerchg'}{'by'}}) { |
| |
my @inststatuses = split(':',$env{'environment.inststatus'}); |
| |
unless (@inststatuses) { |
| |
@inststatuses = ('default'); |
| |
} |
| |
foreach my $status (@inststatuses) { |
| |
if (grep(/^\Q$status\E$/,@{$passwdconf{'crsownerchg'}{'by'}})) { |
| |
$thisallowed.=$rem; |
| |
} |
| |
} |
| |
} |
| |
} |
| } |
} |
| } |
} |
| } |
} |
|
Line 8117 sub allowed {
|
Line 8308 sub allowed {
|
| } elsif ($noblockcheck) { |
} elsif ($noblockcheck) { |
| $thisallowed.=$value; |
$thisallowed.=$value; |
| } else { |
} else { |
| my @blockers = &has_comm_blocking($priv,$symb,$uri); |
my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache); |
| if (@blockers > 0) { |
if (@blockers > 0) { |
| $thisallowed = 'B'; |
$thisallowed = 'B'; |
| } else { |
} else { |
|
Line 8140 sub allowed {
|
Line 8331 sub allowed {
|
| } elsif ($noblockcheck) { |
} elsif ($noblockcheck) { |
| $thisallowed='F'; |
$thisallowed='F'; |
| } else { |
} else { |
| my @blockers = &has_comm_blocking($priv,$symb,$refuri); |
my @blockers = &has_comm_blocking($priv,'',$refuri,'',1); |
| if (@blockers > 0) { |
if (@blockers > 0) { |
| $thisallowed = 'B'; |
$thisallowed = 'B'; |
| } else { |
} else { |
|
Line 8213 sub allowed {
|
Line 8404 sub allowed {
|
| if ($noblockcheck) { |
if ($noblockcheck) { |
| $thisallowed.=$value; |
$thisallowed.=$value; |
| } else { |
} else { |
| my @blockers = &has_comm_blocking($priv,$symb,$uri); |
my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache); |
| if (@blockers > 0) { |
if (@blockers > 0) { |
| $thisallowed = 'B'; |
$thisallowed = 'B'; |
| } else { |
} else { |
|
Line 8226 sub allowed {
|
Line 8417 sub allowed {
|
| $checkreferer=0; |
$checkreferer=0; |
| } |
} |
| } |
} |
| |
|
| if ($checkreferer) { |
if ($checkreferer) { |
| my $refuri=$env{'httpref.'.$orguri}; |
my $refuri=$env{'httpref.'.$orguri}; |
| unless ($refuri) { |
unless ($refuri) { |
|
Line 8258 sub allowed {
|
Line 8449 sub allowed {
|
| } elsif ($noblockcheck) { |
} elsif ($noblockcheck) { |
| $thisallowed.=$value; |
$thisallowed.=$value; |
| } else { |
} else { |
| my @blockers = &has_comm_blocking($priv,$symb,$refuri); |
my @blockers = &has_comm_blocking($priv,'',$refuri,'',1); |
| if (@blockers > 0) { |
if (@blockers > 0) { |
| $thisallowed = 'B'; |
$thisallowed = 'B'; |
| } else { |
} else { |
|
Line 8344 sub allowed {
|
Line 8535 sub allowed {
|
| } |
} |
| } |
} |
| } |
} |
| |
|
| # |
# |
| # Rest of the restrictions depend on selected course |
# Rest of the restrictions depend on selected course |
| # |
# |
|
Line 8513 sub constructaccess {
|
Line 8704 sub constructaccess {
|
| # |
# |
| # User for whom data are being temporarily cached. |
# User for whom data are being temporarily cached. |
| my $cacheduser=''; |
my $cacheduser=''; |
| |
# Course for which data are being temporarily cached. |
| |
my $cachedcid=''; |
| # Cached blockers for this user (a hash of blocking items). |
# Cached blockers for this user (a hash of blocking items). |
| my %cachedblockers=(); |
my %cachedblockers=(); |
| # When the data were last cached. |
# When the data were last cached. |
| my $cachedlast=''; |
my $cachedlast=''; |
| |
|
| sub load_all_blockers { |
sub load_all_blockers { |
| my ($uname,$udom,$blocks)=@_; |
my ($uname,$udom)=@_; |
| if (($uname ne '') && ($udom ne '')) { |
if (($uname ne '') && ($udom ne '')) { |
| if (($cacheduser eq $uname.':'.$udom) && |
if (($cacheduser eq $uname.':'.$udom) && |
| |
($cachedcid eq $env{'request.course.id'}) && |
| (abs($cachedlast-time)<5)) { |
(abs($cachedlast-time)<5)) { |
| return; |
return; |
| } |
} |
| } |
} |
| $cachedlast=time; |
$cachedlast=time; |
| $cacheduser=$uname.':'.$udom; |
$cacheduser=$uname.':'.$udom; |
| %cachedblockers = &get_commblock_resources($blocks); |
$cachedcid=$env{'request.course.id'}; |
| |
%cachedblockers = &get_commblock_resources(); |
| |
return; |
| } |
} |
| |
|
| sub get_comm_blocks { |
sub get_comm_blocks { |
|
Line 8608 sub get_commblock_resources {
|
Line 8804 sub get_commblock_resources {
|
| if ($mapsymb) { |
if ($mapsymb) { |
| if (ref($navmap)) { |
if (ref($navmap)) { |
| my $mapres = $navmap->getBySymb($mapsymb); |
my $mapres = $navmap->getBySymb($mapsymb); |
| @to_test = $mapres->retrieveResources($mapres,undef,0,0,0,1); |
if (ref($mapres)) { |
| foreach my $res (@to_test) { |
my $first = $mapres->map_start(); |
| my $symb = $res->symb(); |
my $finish = $mapres->map_finish(); |
| next if ($symb eq $mapsymb); |
my $it = $navmap->getIterator($first,$finish,undef,0,0); |
| if ($symb ne '') { |
if (ref($it)) { |
| @interval=&EXT("resource.0.interval",$symb); |
my $res; |
| if ($interval[1] eq 'map') { |
while ($res = $it->next(undef,1)) { |
| last; |
next unless (ref($res)); |
| |
my $symb = $res->symb(); |
| |
next if (($symb eq $mapsymb) || ($symb eq '')); |
| |
@interval=&EXT("resource.0.interval",$symb); |
| |
if ($interval[1] eq 'map') { |
| |
if ($res->answerable()) { |
| |
push(@to_test,$res); |
| |
last; |
| |
} |
| |
} |
| } |
} |
| } |
} |
| } |
} |
|
Line 8666 sub get_commblock_resources {
|
Line 8871 sub get_commblock_resources {
|
| } |
} |
| |
|
| sub has_comm_blocking { |
sub has_comm_blocking { |
| my ($priv,$symb,$uri,$blocks) = @_; |
my ($priv,$symb,$uri,$ignoresymbdb,$noenccheck,$blocked,$blocks) = @_; |
| my @blockers; |
my @blockers; |
| return unless ($env{'request.course.id'}); |
return unless ($env{'request.course.id'}); |
| return unless ($priv eq 'bre'); |
return unless ($priv eq 'bre'); |
| return if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/); |
return if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/); |
| return if ($env{'request.state'} eq 'construct'); |
return if ($env{'request.state'} eq 'construct'); |
| &load_all_blockers($env{'user.name'},$env{'user.domain'},$blocks); |
my %blockinfo; |
| return unless (keys(%cachedblockers) > 0); |
if (ref($blocks) eq 'HASH') { |
| |
%blockinfo = &get_commblock_resources($blocks); |
| |
} else { |
| |
&load_all_blockers($env{'user.name'},$env{'user.domain'}); |
| |
%blockinfo = %cachedblockers; |
| |
} |
| |
return unless (keys(%blockinfo) > 0); |
| my (%possibles,@symbs); |
my (%possibles,@symbs); |
| if (!$symb) { |
if (!$symb) { |
| $symb = &symbread($uri,1,1,1,\%possibles); |
$symb = &symbread($uri,1,1,1,\%possibles,$ignoresymbdb,$noenccheck); |
| } |
} |
| if ($symb) { |
if ($symb) { |
| @symbs = ($symb); |
@symbs = ($symb); |
|
Line 8687 sub has_comm_blocking {
|
Line 8898 sub has_comm_blocking {
|
| foreach my $symb (@symbs) { |
foreach my $symb (@symbs) { |
| last if ($noblock); |
last if ($noblock); |
| my ($map,$resid,$resurl)=&decode_symb($symb); |
my ($map,$resid,$resurl)=&decode_symb($symb); |
| foreach my $block (keys(%cachedblockers)) { |
foreach my $block (keys(%blockinfo)) { |
| if ($block =~ /^firstaccess____(.+)$/) { |
if ($block =~ /^firstaccess____(.+)$/) { |
| my $item = $1; |
my $item = $1; |
| if (($item eq $map) || ($item eq $symb)) { |
unless ($blocked) { |
| $noblock = 1; |
if (($item eq $map) || ($item eq $symb)) { |
| last; |
$noblock = 1; |
| |
last; |
| |
} |
| } |
} |
| } |
} |
| if (ref($cachedblockers{$block}) eq 'HASH') { |
if (ref($blockinfo{$block}) eq 'HASH') { |
| if (ref($cachedblockers{$block}{'resources'}) eq 'HASH') { |
if (ref($blockinfo{$block}{'resources'}) eq 'HASH') { |
| if ($cachedblockers{$block}{'resources'}{$symb}) { |
if ($blockinfo{$block}{'resources'}{$symb}) { |
| unless (grep(/^\Q$block\E$/,@blockers)) { |
unless (grep(/^\Q$block\E$/,@blockers)) { |
| push(@blockers,$block); |
push(@blockers,$block); |
| } |
} |
| } |
} |
| } |
} |
| } |
if (ref($blockinfo{$block}{'maps'}) eq 'HASH') { |
| if (ref($cachedblockers{$block}{'maps'}) eq 'HASH') { |
if ($blockinfo{$block}{'maps'}{$map}) { |
| if ($cachedblockers{$block}{'maps'}{$map}) { |
unless (grep(/^\Q$block\E$/,@blockers)) { |
| unless (grep(/^\Q$block\E$/,@blockers)) { |
push(@blockers,$block); |
| push(@blockers,$block); |
} |
| } |
} |
| } |
} |
| } |
} |
| } |
} |
| } |
} |
| return if ($noblock); |
unless ($noblock) { |
| return @blockers; |
return @blockers; |
| |
} |
| |
return; |
| } |
} |
| } |
} |
| |
|
|
Line 10122 sub modifyuserauth {
|
Line 10337 sub modifyuserauth {
|
| ' in domain '.$env{'request.role.domain'}); |
' in domain '.$env{'request.role.domain'}); |
| my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'. |
my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'. |
| &escape($upass),$uhome); |
&escape($upass),$uhome); |
| |
my $ip = &get_requestor_ip(); |
| &log($env{'user.domain'},$env{'user.name'},$env{'user.home'}, |
&log($env{'user.domain'},$env{'user.name'},$env{'user.home'}, |
| 'Authentication changed for '.$udom.', '.$uname.', '.$umode. |
'Authentication changed for '.$udom.', '.$uname.', '.$umode. |
| '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply); |
'(Remote '.$ip.'): '.$reply); |
| &log($udom,,$uname,$uhome, |
&log($udom,,$uname,$uhome, |
| 'Authentication changed by '.$env{'user.domain'}.', '. |
'Authentication changed by '.$env{'user.domain'}.', '. |
| $env{'user.name'}.', '.$umode. |
$env{'user.name'}.', '.$umode. |
| '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply); |
'(Remote '.$ip.'): '.$reply); |
| unless ($reply eq 'ok') { |
unless ($reply eq 'ok') { |
| &logthis('Authentication mode error: '.$reply); |
&logthis('Authentication mode error: '.$reply); |
| return 'error: '.$reply; |
return 'error: '.$reply; |
|
Line 10457 sub writecoursepref {
|
Line 10673 sub writecoursepref {
|
| |
|
| sub createcourse { |
sub createcourse { |
| my ($udom,$description,$url,$course_server,$nonstandard,$inst_code, |
my ($udom,$description,$url,$course_server,$nonstandard,$inst_code, |
| $course_owner,$crstype,$cnum,$context,$category)=@_; |
$course_owner,$crstype,$cnum,$context,$category,$callercontext)=@_; |
| $url=&declutter($url); |
$url=&declutter($url); |
| my $cid=''; |
my $cid=''; |
| if ($context eq 'requestcourses') { |
if ($context eq 'requestcourses') { |
| my $can_create = 0; |
my $can_create = 0; |
| my ($ownername,$ownerdom) = split(':',$course_owner); |
my ($ownername,$ownerdom) = split(':',$course_owner); |
| if ($udom eq $ownerdom) { |
if ($udom eq $ownerdom) { |
| if (&usertools_access($ownername,$ownerdom,$category,undef, |
my $reload; |
| |
if (($callercontext eq 'auto') && |
| |
($ownerdom eq $env{'user.domain'}) && ($ownername eq $env{'user.name'})) { |
| |
$reload = 'reload'; |
| |
} |
| |
if (&usertools_access($ownername,$ownerdom,$category,$reload, |
| $context)) { |
$context)) { |
| $can_create = 1; |
$can_create = 1; |
| } |
} |
|
Line 10649 sub store_userdata {
|
Line 10870 sub store_userdata {
|
| if (($uhome eq '') || ($uhome eq 'no_host')) { |
if (($uhome eq '') || ($uhome eq 'no_host')) { |
| $result = 'error: no_host'; |
$result = 'error: no_host'; |
| } else { |
} else { |
| $storehash->{'ip'} = $ENV{'REMOTE_ADDR'}; |
$storehash->{'ip'} = &get_requestor_ip(); |
| $storehash->{'host'} = $perlvar{'lonHostID'}; |
$storehash->{'host'} = $perlvar{'lonHostID'}; |
| |
|
| my $namevalue=''; |
my $namevalue=''; |
|
Line 12196 sub EXT {
|
Line 12417 sub EXT {
|
| if ($space eq 'name') { |
if ($space eq 'name') { |
| return $ENV{'SERVER_NAME'}; |
return $ENV{'SERVER_NAME'}; |
| } |
} |
| |
} elsif ($realm eq 'client') { |
| |
if ($space eq 'remote_addr') { |
| |
return &get_requestor_ip(); |
| |
} |
| } |
} |
| return ''; |
return ''; |
| } |
} |
|
Line 13024 sub symbverify {
|
Line 13249 sub symbverify {
|
| |
|
| if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db', |
if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db', |
| &GDBM_READER(),0640)) { |
&GDBM_READER(),0640)) { |
| my $noclutter; |
|
| if (($thisurl =~ m{^/adm/wrapper/ext/}) || ($thisurl =~ m{^ext/})) { |
if (($thisurl =~ m{^/adm/wrapper/ext/}) || ($thisurl =~ m{^ext/})) { |
| $thisurl =~ s/\?.+$//; |
$thisurl =~ s/\?.+$//; |
| if ($map =~ m{^uploaded/.+\.page$}) { |
if ($map =~ m{^uploaded/.+\.page$}) { |
| $thisurl =~ s{^(/adm/wrapper|)/ext/}{http://}; |
$thisurl =~ s{^(/adm/wrapper|)/ext/}{http://}; |
| $thisurl =~ s{^\Qhttp://https://\E}{https://}; |
$thisurl =~ s{^\Qhttp://https://\E}{https://}; |
| $noclutter = 1; |
|
| } |
} |
| } |
} |
| my $ids; |
my $ids; |
| if ($noclutter) { |
if ($map =~ m{^uploaded/.+\.page$}) { |
| $ids=$bighash{'ids_'.$thisurl}; |
$ids=$bighash{'ids_'.&clutter_with_no_wrapper($thisurl)}; |
| } else { |
} else { |
| $ids=$bighash{'ids_'.&clutter($thisurl)}; |
$ids=$bighash{'ids_'.&clutter($thisurl)}; |
| } |
} |
|
Line 13135 sub deversion {
|
Line 13358 sub deversion {
|
| # ------------------------------------------------------ Return symb list entry |
# ------------------------------------------------------ Return symb list entry |
| |
|
| sub symbread { |
sub symbread { |
| my ($thisfn,$donotrecurse,$ignorecachednull,$checkforblock,$possibles)=@_; |
my ($thisfn,$donotrecurse,$ignorecachednull,$checkforblock,$possibles, |
| |
$ignoresymbdb,$noenccheck)=@_; |
| my $cache_str='request.symbread.cached.'.$thisfn; |
my $cache_str='request.symbread.cached.'.$thisfn; |
| if (defined($env{$cache_str})) { |
if (defined($env{$cache_str})) { |
| if ($ignorecachednull) { |
unless (ref($possibles) eq 'HASH') { |
| return $env{$cache_str} unless ($env{$cache_str} eq ''); |
if ($ignorecachednull) { |
| } else { |
return $env{$cache_str} unless ($env{$cache_str} eq ''); |
| return $env{$cache_str}; |
} else { |
| |
return $env{$cache_str}; |
| |
} |
| } |
} |
| } |
} |
| # no filename provided? try from environment |
# no filename provided? try from environment |
| unless ($thisfn) { |
unless ($thisfn) { |
| if ($env{'request.symb'}) { |
if ($env{'request.symb'}) { |
| return $env{$cache_str}=&symbclean($env{'request.symb'}); |
return $env{$cache_str}=&symbclean($env{'request.symb'}); |
| } |
} |
| $thisfn=$env{'request.filename'}; |
$thisfn=$env{'request.filename'}; |
| } |
} |
|
Line 13170 sub symbread {
|
Line 13396 sub symbread {
|
| if ($targetfn =~ m|^adm/wrapper/(ext/.*)|) { |
if ($targetfn =~ m|^adm/wrapper/(ext/.*)|) { |
| $targetfn=$1; |
$targetfn=$1; |
| } |
} |
| if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db', |
unless ($ignoresymbdb) { |
| &GDBM_READER(),0640)) { |
if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db', |
| $syval=$hash{$targetfn}; |
&GDBM_READER(),0640)) { |
| untie(%hash); |
$syval=$hash{$targetfn}; |
| |
untie(%hash); |
| |
} |
| |
if ($syval && $checkforblock) { |
| |
my @blockers = &has_comm_blocking('bre',$syval,$thisfn,$ignoresymbdb,$noenccheck); |
| |
if (@blockers) { |
| |
$syval=''; |
| |
} |
| |
} |
| } |
} |
| # ---------------------------------------------------------- There was an entry |
# ---------------------------------------------------------- There was an entry |
| if ($syval) { |
if ($syval) { |
|
Line 13206 sub symbread {
|
Line 13440 sub symbread {
|
| $syval=&encode_symb($bighash{'map_id_'.$mapid}, |
$syval=&encode_symb($bighash{'map_id_'.$mapid}, |
| $resid,$thisfn); |
$resid,$thisfn); |
| if (ref($possibles) eq 'HASH') { |
if (ref($possibles) eq 'HASH') { |
| $possibles->{$syval} = 1; |
unless ($bighash{'randomout_'.$ids} || $env{'request.role.adv'}) { |
| |
$possibles->{$syval} = 1; |
| |
} |
| } |
} |
| if ($checkforblock) { |
if ($checkforblock) { |
| my @blockers = &has_comm_blocking('bre',$syval,$bighash{'src_'.$ids}); |
unless ($bighash{'randomout_'.$ids} || $env{'request.role.adv'}) { |
| if (@blockers) { |
my @blockers = &has_comm_blocking('bre',$syval,$bighash{'src_'.$ids},'',$noenccheck); |
| $syval = ''; |
if (@blockers) { |
| return; |
$syval = ''; |
| |
untie(%bighash); |
| |
return $env{$cache_str}=''; |
| |
} |
| } |
} |
| } |
} |
| } elsif ((!$donotrecurse) || ($checkforblock) || (ref($possibles) eq 'HASH')) { |
} elsif ((!$donotrecurse) || ($checkforblock) || (ref($possibles) eq 'HASH')) { |
|
Line 13231 sub symbread {
|
Line 13470 sub symbread {
|
| if ($bighash{'map_type_'.$mapid} ne 'page') { |
if ($bighash{'map_type_'.$mapid} ne 'page') { |
| my $poss_syval=&encode_symb($bighash{'map_id_'.$mapid}, |
my $poss_syval=&encode_symb($bighash{'map_id_'.$mapid}, |
| $resid,$thisfn); |
$resid,$thisfn); |
| if (ref($possibles) eq 'HASH') { |
next if ($bighash{'randomout_'.$id} && !$env{'request.role.adv'}); |
| $possibles->{$syval} = 1; |
next unless (($noenccheck) || ($bighash{'encrypted_'.$id} eq $env{'request.enc'})); |
| } |
|
| if ($checkforblock) { |
if ($checkforblock) { |
| my @blockers = &has_comm_blocking('bre',$poss_syval,$file); |
my @blockers = &has_comm_blocking('bre',$poss_syval,$file,'',$noenccheck); |
| unless (@blockers > 0) { |
if (@blockers > 0) { |
| |
$syval = ''; |
| |
} else { |
| $syval = $poss_syval; |
$syval = $poss_syval; |
| $realpossible++; |
$realpossible++; |
| } |
} |
|
Line 13244 sub symbread {
|
Line 13484 sub symbread {
|
| $syval = $poss_syval; |
$syval = $poss_syval; |
| $realpossible++; |
$realpossible++; |
| } |
} |
| |
if ($syval) { |
| |
if (ref($possibles) eq 'HASH') { |
| |
$possibles->{$syval} = 1; |
| |
} |
| |
} |
| } |
} |
| } |
} |
| } |
} |
|
Line 13983 sub default_login_domain {
|
Line 14228 sub default_login_domain {
|
| return $domain; |
return $domain; |
| } |
} |
| |
|
| |
sub shared_institution { |
| |
my ($dom,$lonhost) = @_; |
| |
if ($lonhost eq '') { |
| |
$lonhost = $perlvar{'lonHostID'}; |
| |
} |
| |
my $same_intdom; |
| |
my $hostintdom = &internet_dom($lonhost); |
| |
if ($hostintdom ne '') { |
| |
my %iphost = &get_iphost(); |
| |
my $primary_id = &domain($dom,'primary'); |
| |
my $primary_ip = &get_host_ip($primary_id); |
| |
if (ref($iphost{$primary_ip}) eq 'ARRAY') { |
| |
foreach my $id (@{$iphost{$primary_ip}}) { |
| |
my $intdom = &internet_dom($id); |
| |
if ($intdom eq $hostintdom) { |
| |
$same_intdom = 1; |
| |
last; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return $same_intdom; |
| |
} |
| |
|
| sub uses_sts { |
sub uses_sts { |
| my ($ignore_cache) = @_; |
my ($ignore_cache) = @_; |
| my $lonhost = $perlvar{'lonHostID'}; |
my $lonhost = $perlvar{'lonHostID'}; |
|
Line 14021 sub uses_sts {
|
Line 14290 sub uses_sts {
|
| return; |
return; |
| } |
} |
| |
|
| |
sub get_requestor_ip { |
| |
my ($r,$nolookup,$noproxy) = @_; |
| |
my $from_ip; |
| |
if (ref($r)) { |
| |
$from_ip = $r->get_remote_host($nolookup); |
| |
} else { |
| |
$from_ip = $ENV{'REMOTE_ADDR'}; |
| |
} |
| |
return $from_ip if ($noproxy); |
| |
# Who controls proxy settings for server |
| |
my $dom_in_use = $Apache::lonnet::perlvar{'lonDefDomain'}; |
| |
my $proxyinfo = &get_proxy_settings($dom_in_use); |
| |
if ((ref($proxyinfo) eq 'HASH') && ($from_ip)) { |
| |
if ($proxyinfo->{'vpnint'}) { |
| |
if (&ip_match($from_ip,$proxyinfo->{'vpnint'})) { |
| |
return $from_ip; |
| |
} |
| |
} |
| |
if ($proxyinfo->{'trusted'}) { |
| |
if (&ip_match($from_ip,$proxyinfo->{'trusted'})) { |
| |
my $ipheader = $proxyinfo->{'ipheader'}; |
| |
my ($ip,$xfor); |
| |
if (ref($r)) { |
| |
if ($ipheader) { |
| |
$ip = $r->headers_in->{$ipheader}; |
| |
} |
| |
$xfor = $r->headers_in->{'X-Forwarded-For'}; |
| |
} else { |
| |
if ($ipheader) { |
| |
$ip = $ENV{'HTTP_'.uc($ipheader)}; |
| |
} |
| |
$xfor = $ENV{'HTTP_X_FORWARDED_FOR'}; |
| |
} |
| |
if (($ip eq '') && ($xfor ne '')) { |
| |
foreach my $poss_ip (reverse(split(/\s*,\s*/,$xfor))) { |
| |
unless (&ip_match($poss_ip,$proxyinfo->{'trusted'})) { |
| |
$ip = $poss_ip; |
| |
last; |
| |
} |
| |
} |
| |
} |
| |
if ($ip ne '') { |
| |
return $ip; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return $from_ip; |
| |
} |
| |
|
| |
sub get_proxy_settings { |
| |
my ($dom_in_use) = @_; |
| |
my %domdefaults = &Apache::lonnet::get_domain_defaults($dom_in_use); |
| |
my $proxyinfo = { |
| |
ipheader => $domdefaults{'waf_ipheader'}, |
| |
trusted => $domdefaults{'waf_trusted'}, |
| |
vpnint => $domdefaults{'waf_vpnint'}, |
| |
vpnext => $domdefaults{'waf_vpnext'}, |
| |
}; |
| |
return $proxyinfo; |
| |
} |
| |
|
| |
sub ip_match { |
| |
my ($ip,$pattern_str) = @_; |
| |
$ip=Net::CIDR::cidrvalidate($ip); |
| |
if ($ip) { |
| |
return Net::CIDR::cidrlookup($ip,split(/\s*,\s*/,$pattern_str)); |
| |
} |
| |
return; |
| |
} |
| |
|
| |
sub get_proxy_alias { |
| |
my $lonhost = $perlvar{'lonHostID'}; |
| |
if ($lonhost ne '') { |
| |
my ($alias,$cached) = &is_cached_new('proxyalias',$lonhost); |
| |
if ($cached) { |
| |
return $alias; |
| |
} |
| |
my $dom = &Apache::lonnet::host_domain($lonhost); |
| |
if ($dom ne '') { |
| |
my $cachetime = 60*60*24; |
| |
my %domconfig = |
| |
&Apache::lonnet::get_dom('configuration',['wafproxy'],$dom); |
| |
my $alias; |
| |
if (ref($domconfig{'wafproxy'}) eq 'HASH') { |
| |
if (ref($domconfig{'wafproxy'}{'alias'}) eq 'HASH') { |
| |
$alias = $domconfig{'wafproxy'}{'alias'}{$lonhost}; |
| |
} |
| |
} |
| |
return &do_cache_new('proxyalias',$lonhost,$alias,$cachetime); |
| |
} |
| |
} |
| |
return; |
| |
} |
| |
|
| # ------------------------------------------------------------- Declutters URLs |
# ------------------------------------------------------------- Declutters URLs |
| |
|
| sub declutter { |
sub declutter { |
|
Line 14894 BEGIN {
|
Line 15258 BEGIN {
|
| $deftex = LONCAPA::texengine(); |
$deftex = LONCAPA::texengine(); |
| } |
} |
| |
|
| |
# ------------- set default minimum length for passwords for internal auth users |
| |
{ |
| |
$passwdmin = LONCAPA::passwd_min(); |
| |
} |
| |
|
| $memcache=new Cache::Memcached({'servers' => ['127.0.0.1:11211'], |
$memcache=new Cache::Memcached({'servers' => ['127.0.0.1:11211'], |
| 'compress_threshold'=> 20_000, |
'compress_threshold'=> 20_000, |
| }); |
}); |
![[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