|
version 1.955, 2008/04/16 22:59:36
|
version 1.1056.4.11, 2010/10/01 14:26:07
|
|
Line 27
|
Line 27
|
| # |
# |
| ### |
### |
| |
|
| |
=pod |
| |
|
| |
=head1 NAME |
| |
|
| |
Apache::lonnet.pm |
| |
|
| |
=head1 SYNOPSIS |
| |
|
| |
This file is an interface to the lonc processes of |
| |
the LON-CAPA network as well as set of elaborated functions for handling information |
| |
necessary for navigating through a given cluster of LON-CAPA machines within a |
| |
domain. There are over 40 specialized functions in this module which handle the |
| |
reading and transmission of metadata, user information (ids, names, environments, roles, |
| |
logs), file information (storage, reading, directories, extensions, replication, embedded |
| |
styles and descriptors), educational resources (course descriptions, section names and |
| |
numbers), url hashing (to assign roles on a url basis), and translating abbreviated symbols to |
| |
and from more descriptive phrases or explanations. |
| |
|
| |
This is part of the LearningOnline Network with CAPA project |
| |
described at http://www.lon-capa.org. |
| |
|
| |
=head1 Package Variables |
| |
|
| |
These are largely undocumented, so if you decipher one please note it here. |
| |
|
| |
=over 4 |
| |
|
| |
=item $processmarker |
| |
|
| |
Contains the time this process was started and this servers host id. |
| |
|
| |
=item $dumpcount |
| |
|
| |
Counts the number of times a message log flush has been attempted (regardless |
| |
of success) by this process. Used as part of the filename when messages are |
| |
delayed. |
| |
|
| |
=back |
| |
|
| |
=cut |
| |
|
| package Apache::lonnet; |
package Apache::lonnet; |
| |
|
| use strict; |
use strict; |
| use LWP::UserAgent(); |
use LWP::UserAgent(); |
| use HTTP::Date; |
use HTTP::Date; |
| # use Date::Parse; |
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); |
$_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease); |
| |
|
| my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash, |
my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash, |
| %userrolehash, $processmarker, $dumpcount, %coursedombuf, |
%userrolehash, $processmarker, $dumpcount, %coursedombuf, |
| %coursenumbuf, %coursehombuf, %coursedescrbuf, %courseinstcodebuf, |
%coursenumbuf, %coursehombuf, %coursedescrbuf, %courseinstcodebuf, |
| %courseownerbuf, %coursetypebuf); |
%courseownerbuf, %coursetypebuf,$locknum); |
| |
|
| use IO::Socket; |
use IO::Socket; |
| use GDBM_File; |
use GDBM_File; |
|
Line 50 use Time::HiRes qw( gettimeofday tv_inte
|
Line 92 use Time::HiRes qw( gettimeofday tv_inte
|
| use Cache::Memcached; |
use Cache::Memcached; |
| use Digest::MD5; |
use Digest::MD5; |
| use Math::Random; |
use Math::Random; |
| |
use File::MMagic; |
| use LONCAPA qw(:DEFAULT :match); |
use LONCAPA qw(:DEFAULT :match); |
| use LONCAPA::Configuration; |
use LONCAPA::Configuration; |
| |
|
|
Line 61 require Exporter;
|
Line 104 require Exporter;
|
| our @ISA = qw (Exporter); |
our @ISA = qw (Exporter); |
| our @EXPORT = qw(%env); |
our @EXPORT = qw(%env); |
| |
|
| =pod |
|
| |
|
| =head1 Package Variables |
|
| |
|
| These are largely undocumented, so if you decipher one please note it here. |
|
| |
|
| =over 4 |
|
| |
|
| =item $processmarker |
|
| |
|
| Contains the time this process was started and this servers host id. |
|
| |
|
| =item $dumpcount |
|
| |
|
| Counts the number of times a message log flush has been attempted (regardless |
|
| of success) by this process. Used as part of the filename when messages are |
|
| delayed. |
|
| |
|
| =back |
|
| |
|
| =cut |
|
| |
|
| |
|
| # --------------------------------------------------------------------- Logging |
# --------------------------------------------------------------------- Logging |
| { |
{ |
| my $logid; |
my $logid; |
| sub instructor_log { |
sub instructor_log { |
| my ($hash_name,$storehash,$delflag,$uname,$udom)=@_; |
my ($hash_name,$storehash,$delflag,$uname,$udom,$cnum,$cdom)=@_; |
| |
if (($cnum eq '') || ($cdom eq '')) { |
| |
$cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; |
| |
$cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; |
| |
} |
| $logid++; |
$logid++; |
| my $id=time().'00000'.$$.'00000'.$logid; |
my $now = time(); |
| |
my $id=$now.'00000'.$$.'00000'.$logid; |
| return &Apache::lonnet::put('nohist_'.$hash_name, |
return &Apache::lonnet::put('nohist_'.$hash_name, |
| { $id => { |
{ $id => { |
| 'exe_uname' => $env{'user.name'}, |
'exe_uname' => $env{'user.name'}, |
| 'exe_udom' => $env{'user.domain'}, |
'exe_udom' => $env{'user.domain'}, |
| 'exe_time' => time(), |
'exe_time' => $now, |
| 'exe_ip' => $ENV{'REMOTE_ADDR'}, |
'exe_ip' => $ENV{'REMOTE_ADDR'}, |
| 'delflag' => $delflag, |
'delflag' => $delflag, |
| 'logentry' => $storehash, |
'logentry' => $storehash, |
| 'uname' => $uname, |
'uname' => $uname, |
| 'udom' => $udom, |
'udom' => $udom, |
| } |
} |
| }, |
},$cdom,$cnum); |
| $env{'course.'.$env{'request.course.id'}.'.domain'}, |
|
| $env{'course.'.$env{'request.course.id'}.'.num'} |
|
| ); |
|
| } |
} |
| } |
} |
| |
|
|
Line 125 sub logthis {
|
Line 148 sub logthis {
|
| my $now=time; |
my $now=time; |
| my $local=localtime($now); |
my $local=localtime($now); |
| if (open(my $fh,">>$execdir/logs/lonnet.log")) { |
if (open(my $fh,">>$execdir/logs/lonnet.log")) { |
| print $fh "$local ($$): $message\n"; |
my $logstring = $local. " ($$): ".$message."\n"; # Keep any \'s in string. |
| |
print $fh $logstring; |
| close($fh); |
close($fh); |
| } |
} |
| return 1; |
return 1; |
|
Line 156 sub create_connection {
|
Line 180 sub create_connection {
|
| return 0; |
return 0; |
| } |
} |
| |
|
| |
sub get_server_timezone { |
| |
my ($cnum,$cdom) = @_; |
| |
my $home=&homeserver($cnum,$cdom); |
| |
if ($home ne 'no_host') { |
| |
my $cachetime = 24*3600; |
| |
my ($timezone,$cached)=&is_cached_new('servertimezone',$home); |
| |
if (defined($cached)) { |
| |
return $timezone; |
| |
} else { |
| |
my $timezone = &reply('servertimezone',$home); |
| |
return &do_cache_new('servertimezone',$home,$timezone,$cachetime); |
| |
} |
| |
} |
| |
} |
| |
|
| |
sub get_server_loncaparev { |
| |
my ($dom,$lonhost,$ignore_cache,$caller) = @_; |
| |
if (defined($lonhost)) { |
| |
if (!defined(&hostname($lonhost))) { |
| |
undef($lonhost); |
| |
} |
| |
} |
| |
if (!defined($lonhost)) { |
| |
if (defined(&domain($dom,'primary'))) { |
| |
$lonhost=&domain($dom,'primary'); |
| |
if ($lonhost eq 'no_host') { |
| |
undef($lonhost); |
| |
} |
| |
} |
| |
} |
| |
if (defined($lonhost)) { |
| |
my $cachetime = 12*3600; |
| |
if (!$ignore_cache) { |
| |
my ($loncaparev,$cached)=&is_cached_new('serverloncaparev',$lonhost); |
| |
if (defined($cached)) { |
| |
return $loncaparev; |
| |
} |
| |
} |
| |
my ($answer,$loncaparev); |
| |
my @ids=¤t_machine_ids(); |
| |
if (grep(/^\Q$lonhost\E$/,@ids)) { |
| |
$answer = $perlvar{'lonVersion'}; |
| |
if ($answer =~ /^[\'\"]?([\w.\-]+)[\'\"]?$/) { |
| |
$loncaparev = $1; |
| |
} |
| |
} else { |
| |
$answer = &reply('serverloncaparev',$lonhost); |
| |
if (($answer eq 'unknown_cmd') || ($answer eq 'con_lost')) { |
| |
if ($caller eq 'loncron') { |
| |
my $ua=new LWP::UserAgent; |
| |
$ua->timeout(4); |
| |
my $protocol = $protocol{$lonhost}; |
| |
$protocol = 'http' if ($protocol ne 'https'); |
| |
my $url = $protocol.'://'.&hostname($lonhost).'/adm/about.html'; |
| |
my $request=new HTTP::Request('GET',$url); |
| |
my $response=$ua->request($request); |
| |
unless ($response->is_error()) { |
| |
my $content = $response->content; |
| |
if ($content =~ /<p>VERSION\:\s*([\w.\-]+)<\/p>/) { |
| |
$loncaparev = $1; |
| |
} |
| |
} |
| |
} else { |
| |
$loncaparev = $loncaparevs{$lonhost}; |
| |
} |
| |
} elsif ($answer =~ /^[\'\"]?([\w.\-]+)[\'\"]?$/) { |
| |
$loncaparev = $1; |
| |
} |
| |
} |
| |
return &do_cache_new('serverloncaparev',$lonhost,$loncaparev,$cachetime); |
| |
} |
| |
} |
| |
|
| |
sub get_server_homeID { |
| |
my ($hostname,$ignore_cache,$caller) = @_; |
| |
unless ($ignore_cache) { |
| |
my ($serverhomeID,$cached)=&is_cached_new('serverhomeID',$hostname); |
| |
if (defined($cached)) { |
| |
return $serverhomeID; |
| |
} |
| |
} |
| |
my $cachetime = 12*3600; |
| |
my $serverhomeID; |
| |
if ($caller eq 'loncron') { |
| |
my @machine_ids = &machine_ids($hostname); |
| |
foreach my $id (@machine_ids) { |
| |
my $response = &reply('serverhomeID',$id); |
| |
unless (($response eq 'unknown_cmd') || ($response eq 'con_lost')) { |
| |
$serverhomeID = $response; |
| |
last; |
| |
} |
| |
} |
| |
if ($serverhomeID eq '') { |
| |
$serverhomeID = $machine_ids[-1]; |
| |
} |
| |
} else { |
| |
$serverhomeID = $serverhomeIDs{$hostname}; |
| |
} |
| |
return &do_cache_new('serverhomeID',$hostname,$serverhomeID,$cachetime); |
| |
} |
| |
|
| # -------------------------------------------------- Non-critical communication |
# -------------------------------------------------- Non-critical communication |
| sub subreply { |
sub subreply { |
|
Line 487 sub appenv {
|
Line 611 sub appenv {
|
| # ----------------------------------------------------- Delete from Environment |
# ----------------------------------------------------- Delete from Environment |
| |
|
| sub delenv { |
sub delenv { |
| my $delthis=shift; |
my ($delthis,$regexp) = @_; |
| if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) { |
if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) { |
| &logthis("<font color=\"blue\">WARNING: ". |
&logthis("<font color=\"blue\">WARNING: ". |
| "Attempt to delete from environment ".$delthis); |
"Attempt to delete from environment ".$delthis); |
|
Line 500 sub delenv {
|
Line 624 sub delenv {
|
| tie(my %disk_env,'GDBM_File',$env{'user.environment'}, |
tie(my %disk_env,'GDBM_File',$env{'user.environment'}, |
| (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { |
(&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { |
| foreach my $key (keys(%disk_env)) { |
foreach my $key (keys(%disk_env)) { |
| if ($key=~/^$delthis/) { |
if ($regexp) { |
| delete($env{$key}); |
if ($key=~/^$delthis/) { |
| delete($disk_env{$key}); |
delete($env{$key}); |
| } |
delete($disk_env{$key}); |
| |
} |
| |
} else { |
| |
if ($key=~/^\Q$delthis\E/) { |
| |
delete($env{$key}); |
| |
delete($disk_env{$key}); |
| |
} |
| |
} |
| } |
} |
| untie(%disk_env); |
untie(%disk_env); |
| } |
} |
|
Line 524 sub get_env_multiple {
|
Line 655 sub get_env_multiple {
|
| return(@values); |
return(@values); |
| } |
} |
| |
|
| |
# ------------------------------------------------------------------- Locking |
| |
|
| |
sub set_lock { |
| |
my ($text)=@_; |
| |
$locknum++; |
| |
my $id=$$.'-'.$locknum; |
| |
&appenv({'session.locks' => $env{'session.locks'}.','.$id, |
| |
'session.lock.'.$id => $text}); |
| |
return $id; |
| |
} |
| |
|
| |
sub get_locks { |
| |
my $num=0; |
| |
my %texts=(); |
| |
foreach my $lock (split(/\,/,$env{'session.locks'})) { |
| |
if ($lock=~/\w/) { |
| |
$num++; |
| |
$texts{$lock}=$env{'session.lock.'.$lock}; |
| |
} |
| |
} |
| |
return ($num,%texts); |
| |
} |
| |
|
| |
sub remove_lock { |
| |
my ($id)=@_; |
| |
my $newlocks=''; |
| |
foreach my $lock (split(/\,/,$env{'session.locks'})) { |
| |
if (($lock=~/\w/) && ($lock ne $id)) { |
| |
$newlocks.=','.$lock; |
| |
} |
| |
} |
| |
&appenv({'session.locks' => $newlocks}); |
| |
&delenv('session.lock.'.$id); |
| |
} |
| |
|
| |
sub remove_all_locks { |
| |
my $activelocks=$env{'session.locks'}; |
| |
foreach my $lock (split(/\,/,$env{'session.locks'})) { |
| |
if ($lock=~/\w/) { |
| |
&remove_lock($lock); |
| |
} |
| |
} |
| |
} |
| |
|
| |
|
| # ------------------------------------------ Find out current server userload |
# ------------------------------------------ Find out current server userload |
| sub userload { |
sub userload { |
| my $numusers=0; |
my $numusers=0; |
|
Line 580 sub spareserver {
|
Line 756 sub spareserver {
|
| if ($userloadpercent !~ /\d/) { $userloadpercent=0; } |
if ($userloadpercent !~ /\d/) { $userloadpercent=0; } |
| my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent |
my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent |
| : $userloadpercent; |
: $userloadpercent; |
| |
my ($uint_dom,$remotesessions); |
| |
if ($env{'user.domain'}) { |
| |
my $uprimary_id = &Apache::lonnet::domain($env{'user.domain'},'primary'); |
| |
$uint_dom = &Apache::lonnet::internet_dom($uprimary_id); |
| |
my %udomdefaults = &Apache::lonnet::get_domain_defaults($env{'user.domain'}); |
| |
$remotesessions = $udomdefaults{'remotesessions'}; |
| |
} |
| foreach my $try_server (@{ $spareid{'primary'} }) { |
foreach my $try_server (@{ $spareid{'primary'} }) { |
| |
if ($uint_dom) { |
| |
next unless (&spare_can_host($env{'user.domain'},$uint_dom, |
| |
$remotesessions,$try_server)); |
| |
} |
| ($spare_server, $lowest_load) = |
($spare_server, $lowest_load) = |
| &compare_server_load($try_server, $spare_server, $lowest_load); |
&compare_server_load($try_server, $spare_server, $lowest_load); |
| } |
} |
|
Line 590 sub spareserver {
|
Line 776 sub spareserver {
|
| |
|
| if (!$found_server) { |
if (!$found_server) { |
| foreach my $try_server (@{ $spareid{'default'} }) { |
foreach my $try_server (@{ $spareid{'default'} }) { |
| |
if ($uint_dom) { |
| |
next unless (&spare_can_host($env{'user.domain'},$uint_dom, |
| |
$remotesessions,$try_server)); |
| |
} |
| ($spare_server, $lowest_load) = |
($spare_server, $lowest_load) = |
| &compare_server_load($try_server, $spare_server, $lowest_load); |
&compare_server_load($try_server, $spare_server, $lowest_load); |
| } |
} |
| } |
} |
| |
|
| if (!$want_server_name) { |
if (!$want_server_name) { |
| $spare_server="http://".&hostname($spare_server); |
my $protocol = 'http'; |
| |
if ($protocol{$spare_server} eq 'https') { |
| |
$protocol = $protocol{$spare_server}; |
| |
} |
| |
if (defined($spare_server)) { |
| |
my $hostname = &hostname($spare_server); |
| |
if (defined($hostname)) { |
| |
$spare_server = $protocol.'://'.$hostname; |
| |
} |
| |
} |
| } |
} |
| return $spare_server; |
return $spare_server; |
| } |
} |
|
Line 608 sub compare_server_load {
|
Line 807 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/) { |
| next; #didn't get a number from the server |
return; #didn't get a number from the server |
| } |
} |
| |
|
| my $load; |
my $load; |
|
Line 651 sub has_user_session {
|
Line 850 sub has_user_session {
|
| return 0; |
return 0; |
| } |
} |
| |
|
| |
# --------- determine least loaded server in a user's domain which allows login |
| |
|
| |
sub choose_server { |
| |
my ($udom) = @_; |
| |
my %domconfhash = &Apache::loncommon::get_domainconf($udom); |
| |
my %servers = &get_servers($udom); |
| |
my $lowest_load = 30000; |
| |
my ($login_host,$hostname); |
| |
foreach my $lonhost (keys(%servers)) { |
| |
my $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost}; |
| |
if ($loginvia eq '') { |
| |
($login_host, $lowest_load) = |
| |
&compare_server_load($lonhost, $login_host, $lowest_load); |
| |
} |
| |
} |
| |
if ($login_host ne '') { |
| |
$hostname = $servers{$login_host}; |
| |
} |
| |
return ($login_host,$hostname); |
| |
} |
| |
|
| # --------------------------------------------- Try to change a user's password |
# --------------------------------------------- Try to change a user's password |
| |
|
| sub changepass { |
sub changepass { |
| my ($uname,$udom,$currentpass,$newpass,$server,$context)=@_; |
my ($uname,$udom,$currentpass,$newpass,$server,$context)=@_; |
| $currentpass = &escape($currentpass); |
$currentpass = &escape($currentpass); |
| $newpass = &escape($newpass); |
$newpass = &escape($newpass); |
| my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context", |
my $lonhost = $perlvar{'lonHostID'}; |
| |
my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context:$lonhost", |
| $server); |
$server); |
| if (! $answer) { |
if (! $answer) { |
| &logthis("No reply on password change request to $server ". |
&logthis("No reply on password change request to $server ". |
|
Line 682 sub changepass {
|
Line 903 sub changepass {
|
| } elsif ($answer =~ "^refused") { |
} elsif ($answer =~ "^refused") { |
| &logthis("$server refused to change $uname in $udom password because ". |
&logthis("$server refused to change $uname in $udom password because ". |
| "it was sent an unencrypted request to change the password."); |
"it was sent an unencrypted request to change the password."); |
| |
} elsif ($answer =~ "invalid_client") { |
| |
&logthis("$server refused to change $uname in $udom password because ". |
| |
"it was a reset by e-mail originating from an invalid server."); |
| } |
} |
| return $answer; |
return $answer; |
| } |
} |
|
Line 705 sub queryauthenticate {
|
Line 929 sub queryauthenticate {
|
| # --------- Try to authenticate user from domain's lib servers (first this one) |
# --------- Try to authenticate user from domain's lib servers (first this one) |
| |
|
| sub authenticate { |
sub authenticate { |
| my ($uname,$upass,$udom,$checkdefauth)=@_; |
my ($uname,$upass,$udom,$checkdefauth,$clientcancheckhost)=@_; |
| $upass=&escape($upass); |
$upass=&escape($upass); |
| $uname= &LONCAPA::clean_username($uname); |
$uname= &LONCAPA::clean_username($uname); |
| my $uhome=&homeserver($uname,$udom,1); |
my $uhome=&homeserver($uname,$udom,1); |
|
Line 728 sub authenticate {
|
Line 952 sub authenticate {
|
| return 'no_host'; |
return 'no_host'; |
| } |
} |
| } |
} |
| my $answer=reply("encrypt:auth:$udom:$uname:$upass:$checkdefauth",$uhome); |
my $answer=reply("encrypt:auth:$udom:$uname:$upass:$checkdefauth:$clientcancheckhost",$uhome); |
| if ($answer eq 'authorized') { |
if ($answer eq 'authorized') { |
| if ($newhome) { |
if ($newhome) { |
| &logthis("User $uname at $udom authorized by $uhome, but needs account"); |
&logthis("User $uname at $udom authorized by $uhome, but needs account"); |
|
Line 746 sub authenticate {
|
Line 970 sub authenticate {
|
| return 'no_host'; |
return 'no_host'; |
| } |
} |
| |
|
| |
sub can_host_session { |
| |
my ($udom,$lonhost,$remoterev,$remotesessions,$hostedsessions) = @_; |
| |
my $canhost = 1; |
| |
my $host_idn = &Apache::lonnet::internet_dom($lonhost); |
| |
if (ref($remotesessions) eq 'HASH') { |
| |
if (ref($remotesessions->{'excludedomain'}) eq 'ARRAY') { |
| |
if (grep(/^\Q$host_idn\E$/,@{$remotesessions->{'excludedomain'}})) { |
| |
$canhost = 0; |
| |
} else { |
| |
$canhost = 1; |
| |
} |
| |
} |
| |
if (ref($remotesessions->{'includedomain'}) eq 'ARRAY') { |
| |
if (grep(/^\Q$host_idn\E$/,@{$remotesessions->{'includedomain'}})) { |
| |
$canhost = 1; |
| |
} else { |
| |
$canhost = 0; |
| |
} |
| |
} |
| |
if ($canhost) { |
| |
if ($remotesessions->{'version'} ne '') { |
| |
my ($reqmajor,$reqminor) = ($remotesessions->{'version'} =~ /^(\d+)\.(\d+)$/); |
| |
if ($reqmajor ne '' && $reqminor ne '') { |
| |
if ($remoterev =~ /^\'?(\d+)\.(\d+)/) { |
| |
my $major = $1; |
| |
my $minor = $2; |
| |
if (($major < $reqmajor ) || |
| |
(($major == $reqmajor) && ($minor < $reqminor))) { |
| |
$canhost = 0; |
| |
} |
| |
} else { |
| |
$canhost = 0; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
if ($canhost) { |
| |
if (ref($hostedsessions) eq 'HASH') { |
| |
if (ref($hostedsessions->{'excludedomain'}) eq 'ARRAY') { |
| |
if (grep(/^\Q$udom\E$/,@{$hostedsessions->{'excludedomain'}})) { |
| |
$canhost = 0; |
| |
} else { |
| |
$canhost = 1; |
| |
} |
| |
} |
| |
if (ref($hostedsessions->{'includedomain'}) eq 'ARRAY') { |
| |
if (grep(/^\Q$udom\E$/,@{$hostedsessions->{'includedomain'}})) { |
| |
$canhost = 1; |
| |
} else { |
| |
$canhost = 0; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return $canhost; |
| |
} |
| |
|
| |
sub spare_can_host { |
| |
my ($udom,$uint_dom,$remotesessions,$try_server)=@_; |
| |
my $canhost=1; |
| |
my @intdoms; |
| |
my $internet_names = &Apache::lonnet::get_internet_names($try_server); |
| |
if (ref($internet_names) eq 'ARRAY') { |
| |
@intdoms = @{$internet_names}; |
| |
} |
| |
unless (grep(/^\Q$uint_dom\E$/,@intdoms)) { |
| |
my $serverhomeID = &Apache::lonnet::get_server_homeID($try_server); |
| |
my $serverhomedom = &Apache::lonnet::host_domain($serverhomeID); |
| |
my %defdomdefaults = &Apache::lonnet::get_domain_defaults($serverhomedom); |
| |
my $remoterev = &Apache::lonnet::get_server_loncaparev(undef,$try_server); |
| |
$canhost = &can_host_session($udom,$try_server,$remoterev, |
| |
$remotesessions, |
| |
$defdomdefaults{'hostedsessions'}); |
| |
} |
| |
return $canhost; |
| |
} |
| |
|
| # ---------------------- Find the homebase for a user from domain's lib servers |
# ---------------------- Find the homebase for a user from domain's lib servers |
| |
|
| my %homecache; |
my %homecache; |
|
Line 831 sub idput {
|
Line 1133 sub idput {
|
| } |
} |
| } |
} |
| |
|
| # ------------------------------------------- get items from domain db files |
# ------------------------------dump from db file owned by domainconfig user |
| |
sub dump_dom { |
| |
my ($namespace,$udom,$regexp,$range)=@_; |
| |
if (!$udom) { |
| |
$udom=$env{'user.domain'}; |
| |
} |
| |
my %returnhash; |
| |
if ($udom) { |
| |
my $uname = &get_domainconfiguser($udom); |
| |
%returnhash = &dump($namespace,$udom,$uname,$regexp,$range); |
| |
} |
| |
return %returnhash; |
| |
} |
| |
|
| |
# ------------------------------------------ get items from domain db files |
| |
|
| sub get_dom { |
sub get_dom { |
| my ($namespace,$storearr,$udom,$uhome)=@_; |
my ($namespace,$storearr,$udom,$uhome)=@_; |
|
Line 905 sub put_dom {
|
Line 1221 sub put_dom {
|
| } |
} |
| } |
} |
| |
|
| |
# --------------------- newput for items in db file owned by domainconfig user |
| |
sub newput_dom { |
| |
my ($namespace,$storehash,$udom) = @_; |
| |
my $result; |
| |
if (!$udom) { |
| |
$udom=$env{'user.domain'}; |
| |
} |
| |
if ($udom) { |
| |
my $uname = &get_domainconfiguser($udom); |
| |
$result = &newput($namespace,$storehash,$udom,$uname); |
| |
} |
| |
return $result; |
| |
} |
| |
|
| |
# --------------------- delete for items in db file owned by domainconfig user |
| |
sub del_dom { |
| |
my ($namespace,$storearr,$udom)=@_; |
| |
if (ref($storearr) eq 'ARRAY') { |
| |
if (!$udom) { |
| |
$udom=$env{'user.domain'}; |
| |
} |
| |
if ($udom) { |
| |
my $uname = &get_domainconfiguser($udom); |
| |
return &del($namespace,$storearr,$udom,$uname); |
| |
} |
| |
} |
| |
} |
| |
|
| |
# ----------------------------------construct domainconfig user for a domain |
| |
sub get_domainconfiguser { |
| |
my ($udom) = @_; |
| |
return $udom.'-domainconfig'; |
| |
} |
| |
|
| sub retrieve_inst_usertypes { |
sub retrieve_inst_usertypes { |
| my ($udom) = @_; |
my ($udom) = @_; |
| my (%returnhash,@order); |
my (%returnhash,@order); |
| if (defined(&domain($udom,'primary'))) { |
my %domdefs = &Apache::lonnet::get_domain_defaults($udom); |
| my $uhome=&domain($udom,'primary'); |
if ((ref($domdefs{'inststatustypes'}) eq 'HASH') && |
| my $rep=&reply("inst_usertypes:$udom",$uhome); |
(ref($domdefs{'inststatusorder'}) eq 'ARRAY')) { |
| my ($hashitems,$orderitems) = split(/:/,$rep); |
%returnhash = %{$domdefs{'inststatustypes'}}; |
| my @pairs=split(/\&/,$hashitems); |
@order = @{$domdefs{'inststatusorder'}}; |
| foreach my $item (@pairs) { |
|
| my ($key,$value)=split(/=/,$item,2); |
|
| $key = &unescape($key); |
|
| next if ($key =~ /^error: 2 /); |
|
| $returnhash{$key}=&thaw_unescape($value); |
|
| } |
|
| my @esc_order = split(/\&/,$orderitems); |
|
| foreach my $item (@esc_order) { |
|
| push(@order,&unescape($item)); |
|
| } |
|
| } else { |
} else { |
| &logthis("get_dom failed - no primary domain server for $udom"); |
if (defined(&domain($udom,'primary'))) { |
| |
my $uhome=&domain($udom,'primary'); |
| |
my $rep=&reply("inst_usertypes:$udom",$uhome); |
| |
if ($rep =~ /^(con_lost|error|no_such_host|refused)/) { |
| |
&logthis("get_dom failed - $rep returned from $uhome in domain: $udom"); |
| |
return (\%returnhash,\@order); |
| |
} |
| |
my ($hashitems,$orderitems) = split(/:/,$rep); |
| |
my @pairs=split(/\&/,$hashitems); |
| |
foreach my $item (@pairs) { |
| |
my ($key,$value)=split(/=/,$item,2); |
| |
$key = &unescape($key); |
| |
next if ($key =~ /^error: 2 /); |
| |
$returnhash{$key}=&thaw_unescape($value); |
| |
} |
| |
my @esc_order = split(/\&/,$orderitems); |
| |
foreach my $item (@esc_order) { |
| |
push(@order,&unescape($item)); |
| |
} |
| |
} else { |
| |
&logthis("get_dom failed - no primary domain server for $udom"); |
| |
} |
| } |
} |
| return (\%returnhash,\@order); |
return (\%returnhash,\@order); |
| } |
} |
|
Line 1148 sub inst_userrules {
|
Line 1509 sub inst_userrules {
|
| return (\%ruleshash,\@ruleorder); |
return (\%ruleshash,\@ruleorder); |
| } |
} |
| |
|
| # ------------------------- Get Authentication and Language Defaults for Domain |
# ------------- Get Authentication, Language and User Tools Defaults for Domain |
| |
|
| sub get_domain_defaults { |
sub get_domain_defaults { |
| my ($domain) = @_; |
my ($domain) = @_; |
| my $cachetime = 60*60*24; |
my $cachetime = 60*60*24; |
| my ($defauthtype,$defautharg,$deflang); |
|
| my ($result,$cached)=&is_cached_new('domdefaults',$domain); |
my ($result,$cached)=&is_cached_new('domdefaults',$domain); |
| if (defined($cached)) { |
if (defined($cached)) { |
| if (ref($result) eq 'HASH') { |
if (ref($result) eq 'HASH') { |
|
Line 1162 sub get_domain_defaults {
|
Line 1522 sub get_domain_defaults {
|
| } |
} |
| my %domdefaults; |
my %domdefaults; |
| my %domconfig = |
my %domconfig = |
| &Apache::lonnet::get_dom('configuration',['defaults'],$domain); |
&Apache::lonnet::get_dom('configuration',['defaults','quotas', |
| |
'requestcourses','inststatus', |
| |
'coursedefaults','usersessions'],$domain); |
| 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'}; |
| $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'}; |
$domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'}; |
| $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{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_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'); |
| $domdefaults{'auth_arg_def'} = &domain($domain,'auth_arg_def'); |
$domdefaults{'auth_arg_def'} = &domain($domain,'auth_arg_def'); |
| } |
} |
| |
if (ref($domconfig{'quotas'}) eq 'HASH') { |
| |
if (ref($domconfig{'quotas'}{'defaultquota'}) eq 'HASH') { |
| |
$domdefaults{'defaultquota'} = $domconfig{'quotas'}{'defaultquota'}; |
| |
} else { |
| |
$domdefaults{'defaultquota'} = $domconfig{'quotas'}; |
| |
} |
| |
my @usertools = ('aboutme','blog','portfolio'); |
| |
foreach my $item (@usertools) { |
| |
if (ref($domconfig{'quotas'}{$item}) eq 'HASH') { |
| |
$domdefaults{$item} = $domconfig{'quotas'}{$item}; |
| |
} |
| |
} |
| |
} |
| |
if (ref($domconfig{'requestcourses'}) eq 'HASH') { |
| |
foreach my $item ('official','unofficial','community') { |
| |
$domdefaults{$item} = $domconfig{'requestcourses'}{$item}; |
| |
} |
| |
} |
| |
if (ref($domconfig{'inststatus'}) eq 'HASH') { |
| |
foreach my $item ('inststatustypes','inststatusorder') { |
| |
$domdefaults{$item} = $domconfig{'inststatus'}{$item}; |
| |
} |
| |
} |
| |
if (ref($domconfig{'coursedefaults'}) eq 'HASH') { |
| |
foreach my $item ('canuse_pdfforms') { |
| |
$domdefaults{$item} = $domconfig{'coursedefaults'}{$item}; |
| |
} |
| |
} |
| |
if (ref($domconfig{'usersessions'}) eq 'HASH') { |
| |
if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') { |
| |
$domdefaults{'remotesessions'} = $domconfig{'usersessions'}{'remote'}; |
| |
} |
| |
if (ref($domconfig{'usersessions'}{'hosted'}) eq 'HASH') { |
| |
$domdefaults{'hostedsessions'} = $domconfig{'usersessions'}{'hosted'}; |
| |
} |
| |
} |
| &Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults, |
&Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults, |
| $cachetime); |
$cachetime); |
| return %domdefaults; |
return %domdefaults; |
|
Line 1357 sub getsection {
|
Line 1757 sub getsection {
|
| # If there is a role which has expired, return it. |
# If there is a role which has expired, return it. |
| # |
# |
| $courseid = &courseid_to_courseurl($courseid); |
$courseid = &courseid_to_courseurl($courseid); |
| my %roleshash = &dump('roles',$udom,$unam,$courseid); |
my $extra = &freeze_escape({'skipcheck' => 1}); |
| |
my %roleshash = &dump('roles',$udom,$unam,$courseid,undef,$extra); |
| foreach my $key (keys(%roleshash)) { |
foreach my $key (keys(%roleshash)) { |
| next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/); |
next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/); |
| my $section=$1; |
my $section=$1; |
|
Line 1496 sub purge_remembered {
|
Line 1897 sub purge_remembered {
|
| |
|
| sub userenvironment { |
sub userenvironment { |
| my ($udom,$unam,@what)=@_; |
my ($udom,$unam,@what)=@_; |
| |
my $items; |
| |
foreach my $item (@what) { |
| |
$items.=&escape($item).'&'; |
| |
} |
| |
$items=~s/\&$//; |
| my %returnhash=(); |
my %returnhash=(); |
| my @answer=split(/\&/, |
my $uhome = &homeserver($unam,$udom); |
| &reply('get:'.$udom.':'.$unam.':environment:'.join('&',@what), |
unless ($uhome eq 'no_host') { |
| &homeserver($unam,$udom))); |
my @answer=split(/\&/, |
| my $i; |
&reply('get:'.$udom.':'.$unam.':environment:'.$items,$uhome)); |
| for ($i=0;$i<=$#what;$i++) { |
if ($#answer==0 && $answer[0] =~ /^(con_lost|error:|no_such_host)/i) { |
| $returnhash{$what[$i]}=&unescape($answer[$i]); |
return %returnhash; |
| |
} |
| |
my $i; |
| |
for ($i=0;$i<=$#what;$i++) { |
| |
$returnhash{$what[$i]}=&unescape($answer[$i]); |
| |
} |
| } |
} |
| return %returnhash; |
return %returnhash; |
| } |
} |
|
Line 1695 sub ssi_body {
|
Line 2106 sub ssi_body {
|
| } |
} |
| my $output=''; |
my $output=''; |
| my $response; |
my $response; |
| if ($filelink=~/^http\:/) { |
if ($filelink=~/^https?\:/) { |
| ($output,$response)=&externalssi($filelink); |
($output,$response)=&externalssi($filelink); |
| } else { |
} else { |
| |
$filelink .= $filelink=~/\?/ ? '&' : '?'; |
| |
$filelink .= 'inhibitmenu=yes'; |
| ($output,$response)=&ssi($filelink,%form); |
($output,$response)=&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; |
|
Line 1741 sub ssi {
|
Line 2154 sub ssi {
|
| &Apache::lonenc::check_encrypt(\$fn); |
&Apache::lonenc::check_encrypt(\$fn); |
| if (%form) { |
if (%form) { |
| $request=new HTTP::Request('POST',&absolute_url().$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',&absolute_url().$fn); |
$request=new HTTP::Request('GET',&absolute_url().$fn); |
| } |
} |
|
Line 1839 sub process_coursefile {
|
Line 2252 sub process_coursefile {
|
| print $fh $env{'form.'.$source}; |
print $fh $env{'form.'.$source}; |
| close($fh); |
close($fh); |
| if ($parser eq 'parse') { |
if ($parser eq 'parse') { |
| my $parse_result = &extract_embedded_items($filepath,$fname,$allfiles,$codebase); |
my $mm = new File::MMagic; |
| unless ($parse_result eq 'ok') { |
my $mime_type = $mm->checktype_filename($filepath.'/'.$fname); |
| &logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result); |
if ($mime_type eq 'text/html') { |
| |
my $parse_result = &extract_embedded_items($filepath.'/'.$fname,$allfiles,$codebase); |
| |
unless ($parse_result eq 'ok') { |
| |
&logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result); |
| |
} |
| } |
} |
| } |
} |
| $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, |
$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, |
|
Line 1918 sub clean_filename {
|
Line 2335 sub clean_filename {
|
| $fname=~s/\.(\d+)(?=\.)/_$1/g; |
$fname=~s/\.(\d+)(?=\.)/_$1/g; |
| return $fname; |
return $fname; |
| } |
} |
| |
# This Function checks if an Image's dimensions exceed either $resizewidth (width) |
| |
# or $resizeheight (height) - both pixels. If so, the image is scaled to produce an |
| |
# image with the same aspect ratio as the original, but with dimensions which do |
| |
# not exceed $resizewidth and $resizeheight. |
| |
|
| |
sub resizeImage { |
| |
my ($img_path,$resizewidth,$resizeheight) = @_; |
| |
my $ima = Image::Magick->new; |
| |
my $resized; |
| |
if (-e $img_path) { |
| |
$ima->Read($img_path); |
| |
if (($resizewidth =~ /^\d+$/) && ($resizeheight > 0)) { |
| |
my $width = $ima->Get('width'); |
| |
my $height = $ima->Get('height'); |
| |
if ($width > $resizewidth) { |
| |
my $factor = $width/$resizewidth; |
| |
my $newheight = $height/$factor; |
| |
$ima->Scale(width=>$resizewidth,height=>$newheight); |
| |
$resized = 1; |
| |
} |
| |
} |
| |
if (($resizeheight =~ /^\d+$/) && ($resizeheight > 0)) { |
| |
my $width = $ima->Get('width'); |
| |
my $height = $ima->Get('height'); |
| |
if ($height > $resizeheight) { |
| |
my $factor = $height/$resizeheight; |
| |
my $newwidth = $width/$factor; |
| |
$ima->Scale(width=>$newwidth,height=>$resizeheight); |
| |
$resized = 1; |
| |
} |
| |
} |
| |
if ($resized) { |
| |
$ima->Write($img_path); |
| |
} |
| |
} |
| |
return; |
| |
} |
| |
|
| # --------------- Take an uploaded file and put it into the userfiles directory |
# --------------- Take an uploaded file and put it into the userfiles directory |
| # input: $formname - the contents of the file are in $env{"form.$formname"} |
# input: $formname - the contents of the file are in $env{"form.$formname"} |
|
Line 1932 sub clean_filename {
|
Line 2386 sub clean_filename {
|
| # $dsetudom - domain for permanaent storage of uploaded file |
# $dsetudom - domain for permanaent storage of uploaded file |
| # $thumbwidth - width (pixels) of thumbnail to make for uploaded image |
# $thumbwidth - width (pixels) of thumbnail to make for uploaded image |
| # $thumbheight - height (pixels) of thumbnail to make for uploaded image |
# $thumbheight - height (pixels) of thumbnail to make for uploaded image |
| |
# $resizewidth - width (pixels) to which to resize uploaded image |
| |
# $resizeheight - height (pixels) to which to resize uploaded image |
| # |
# |
| # output: url of file in userspace, or error: <message> |
# output: url of file in userspace, or error: <message> |
| # or /adm/notfound.html if failure to upload occurse |
# or /adm/notfound.html if failure to upload occurse |
| |
|
| |
|
| sub userfileupload { |
sub userfileupload { |
| my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname, |
my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname, |
| $destudom,$thumbwidth,$thumbheight)=@_; |
$destudom,$thumbwidth,$thumbheight,$resizewidth,$resizeheight)=@_; |
| if (!defined($subdir)) { $subdir='unknown'; } |
if (!defined($subdir)) { $subdir='unknown'; } |
| my $fname=$env{'form.'.$formname.'.filename'}; |
my $fname=$env{'form.'.$formname.'.filename'}; |
| $fname=&clean_filename($fname); |
$fname=&clean_filename($fname); |
|
Line 1977 sub userfileupload {
|
Line 2432 sub userfileupload {
|
| close($fh); |
close($fh); |
| return $fullpath.'/'.$fname; |
return $fullpath.'/'.$fname; |
| } |
} |
| |
if ($subdir eq 'scantron') { |
| |
$fname = 'scantron_orig_'.$fname; |
| |
} else { |
| # Create the directory if not present |
# Create the directory if not present |
| $fname="$subdir/$fname"; |
$fname="$subdir/$fname"; |
| |
} |
| if ($coursedoc) { |
if ($coursedoc) { |
| my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'}; |
my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'}; |
| my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'}; |
my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'}; |
| if ($env{'form.folder'} =~ m/^(default|supplemental)/) { |
if ($env{'form.folder'} =~ m/^(default|supplemental)/) { |
| return &finishuserfileupload($docuname,$docudom, |
return &finishuserfileupload($docuname,$docudom, |
| $formname,$fname,$parser,$allfiles, |
$formname,$fname,$parser,$allfiles, |
| $codebase,$thumbwidth,$thumbheight); |
$codebase,$thumbwidth,$thumbheight, |
| |
$resizewidth,$resizeheight); |
| } else { |
} else { |
| $fname=$env{'form.folder'}.'/'.$fname; |
$fname=$env{'form.folder'}.'/'.$fname; |
| return &process_coursefile('uploaddoc',$docuname,$docudom, |
return &process_coursefile('uploaddoc',$docuname,$docudom, |
|
Line 1998 sub userfileupload {
|
Line 2457 sub userfileupload {
|
| my $docudom=$destudom; |
my $docudom=$destudom; |
| return &finishuserfileupload($docuname,$docudom,$formname,$fname, |
return &finishuserfileupload($docuname,$docudom,$formname,$fname, |
| $parser,$allfiles,$codebase, |
$parser,$allfiles,$codebase, |
| $thumbwidth,$thumbheight); |
$thumbwidth,$thumbheight, |
| |
$resizewidth,$resizeheight); |
| |
|
| } else { |
} else { |
| my $docuname=$env{'user.name'}; |
my $docuname=$env{'user.name'}; |
|
Line 2009 sub userfileupload {
|
Line 2469 sub userfileupload {
|
| } |
} |
| return &finishuserfileupload($docuname,$docudom,$formname,$fname, |
return &finishuserfileupload($docuname,$docudom,$formname,$fname, |
| $parser,$allfiles,$codebase, |
$parser,$allfiles,$codebase, |
| $thumbwidth,$thumbheight); |
$thumbwidth,$thumbheight, |
| |
$resizewidth,$resizeheight); |
| } |
} |
| } |
} |
| |
|
| sub finishuserfileupload { |
sub finishuserfileupload { |
| my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase, |
my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase, |
| $thumbwidth,$thumbheight) = @_; |
$thumbwidth,$thumbheight,$resizewidth,$resizeheight) = @_; |
| my $path=$docudom.'/'.$docuname.'/'; |
my $path=$docudom.'/'.$docuname.'/'; |
| my $filepath=$perlvar{'lonDocRoot'}; |
my $filepath=$perlvar{'lonDocRoot'}; |
| |
|
| my ($fnamepath,$file,$fetchthumb); |
my ($fnamepath,$file,$fetchthumb); |
| $file=$fname; |
$file=$fname; |
| if ($fname=~m|/|) { |
if ($fname=~m|/|) { |
|
Line 2032 sub finishuserfileupload {
|
Line 2494 sub finishuserfileupload {
|
| mkdir($filepath,0777); |
mkdir($filepath,0777); |
| } |
} |
| } |
} |
| |
|
| # Save the file |
# Save the file |
| { |
{ |
| if (!open(FH,'>'.$filepath.'/'.$file)) { |
if (!open(FH,'>'.$filepath.'/'.$file)) { |
|
Line 2045 sub finishuserfileupload {
|
Line 2508 sub finishuserfileupload {
|
| return '/adm/notfound.html'; |
return '/adm/notfound.html'; |
| } |
} |
| close(FH); |
close(FH); |
| |
if ($resizewidth && $resizeheight) { |
| |
my $mm = new File::MMagic; |
| |
my $mime_type = $mm->checktype_filename($filepath.'/'.$file); |
| |
if ($mime_type =~ m{^image/}) { |
| |
&resizeImage($filepath.'/'.$file,$resizewidth,$resizeheight); |
| |
} |
| |
} |
| } |
} |
| if ($parser eq 'parse') { |
if ($parser eq 'parse') { |
| my $parse_result = &extract_embedded_items($filepath,$file,$allfiles, |
my $mm = new File::MMagic; |
| $codebase); |
my $mime_type = $mm->checktype_filename($filepath.'/'.$file); |
| unless ($parse_result eq 'ok') { |
if ($mime_type eq 'text/html') { |
| &logthis('Failed to parse '.$filepath.$file. |
my $parse_result = &extract_embedded_items($filepath.'/'.$file, |
| ' for embedded media: '.$parse_result); |
$allfiles,$codebase); |
| |
unless ($parse_result eq 'ok') { |
| |
&logthis('Failed to parse '.$filepath.$file. |
| |
' for embedded media: '.$parse_result); |
| |
} |
| } |
} |
| } |
} |
| if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) { |
if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) { |
|
Line 2066 sub finishuserfileupload {
|
Line 2540 sub finishuserfileupload {
|
| |
|
| # Notify homeserver to grep it |
# Notify homeserver to grep it |
| # |
# |
| my $docuhome=&homeserver($docuname,$docudom); |
my $docuhome=&homeserver($docuname,$docudom); |
| my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome); |
my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome); |
| if ($fetchresult eq 'ok') { |
if ($fetchresult eq 'ok') { |
| if ($fetchthumb) { |
if ($fetchthumb) { |
|
Line 2087 sub finishuserfileupload {
|
Line 2561 sub finishuserfileupload {
|
| } |
} |
| |
|
| sub extract_embedded_items { |
sub extract_embedded_items { |
| my ($filepath,$file,$allfiles,$codebase,$content) = @_; |
my ($fullpath,$allfiles,$codebase,$content) = @_; |
| my @state = (); |
my @state = (); |
| my %javafiles = ( |
my %javafiles = ( |
| codebase => '', |
codebase => '', |
|
Line 2102 sub extract_embedded_items {
|
Line 2576 sub extract_embedded_items {
|
| if ($content) { |
if ($content) { |
| $p = HTML::LCParser->new($content); |
$p = HTML::LCParser->new($content); |
| } else { |
} else { |
| $p = HTML::LCParser->new($filepath.'/'.$file); |
$p = HTML::LCParser->new($fullpath); |
| } |
} |
| while (my $t=$p->get_token()) { |
while (my $t=$p->get_token()) { |
| if ($t->[0] eq 'S') { |
if ($t->[0] eq 'S') { |
|
Line 2198 sub add_filetype {
|
Line 2672 sub add_filetype {
|
| } |
} |
| |
|
| sub removeuploadedurl { |
sub removeuploadedurl { |
| my ($url)=@_; |
my ($url)=@_; |
| my (undef,undef,$udom,$uname,$fname)=split('/',$url,5); |
my (undef,undef,$udom,$uname,$fname)=split('/',$url,5); |
| return &removeuserfile($uname,$udom,$fname); |
return &removeuserfile($uname,$udom,$fname); |
| } |
} |
| |
|
| sub removeuserfile { |
sub removeuserfile { |
| my ($docuname,$docudom,$fname)=@_; |
my ($docuname,$docudom,$fname)=@_; |
| my $home=&homeserver($docuname,$docudom); |
my $home=&homeserver($docuname,$docudom); |
| my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home); |
my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home); |
| if ($result eq 'ok') { |
if ($result eq 'ok') { |
| if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) { |
if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) { |
| my $metafile = $fname.'.meta'; |
my $metafile = $fname.'.meta'; |
| my $metaresult = &removeuserfile($docuname,$docudom,$metafile); |
my $metaresult = &removeuserfile($docuname,$docudom,$metafile); |
| my $url = "/uploaded/$docudom/$docuname/$fname"; |
my $url = "/uploaded/$docudom/$docuname/$fname"; |
| my ($file,$group) = (&parse_portfolio_url($url))[3,4]; |
my ($file,$group) = (&parse_portfolio_url($url))[3,4]; |
| my $sqlresult = |
my $sqlresult = |
| &update_portfolio_table($docuname,$docudom,$file, |
&update_portfolio_table($docuname,$docudom,$file, |
| 'portfolio_metadata',$group, |
'portfolio_metadata',$group, |
|
Line 2355 sub flushcourselogs {
|
Line 2829 sub flushcourselogs {
|
| # Reverse lookup of domain roles (dc, ad, li, sc, au) |
# Reverse lookup of domain roles (dc, ad, li, sc, au) |
| # |
# |
| my %domrolebuffer = (); |
my %domrolebuffer = (); |
| foreach my $entry (keys %domainrolehash) { |
foreach my $entry (keys(%domainrolehash)) { |
| my ($role,$uname,$udom,$runame,$rudom,$rsec)=split(/:/,$entry); |
my ($role,$uname,$udom,$runame,$rudom,$rsec)=split(/:/,$entry); |
| if ($domrolebuffer{$rudom}) { |
if ($domrolebuffer{$rudom}) { |
| $domrolebuffer{$rudom}.='&'.&escape($entry). |
$domrolebuffer{$rudom}.='&'.&escape($entry). |
|
Line 2415 sub courseacclog {
|
Line 2889 sub courseacclog {
|
| # FIXME: Probably ought to escape things.... |
# FIXME: Probably ought to escape things.... |
| foreach my $key (keys(%env)) { |
foreach my $key (keys(%env)) { |
| if ($key=~/^form\.(.*)/) { |
if ($key=~/^form\.(.*)/) { |
| $what.=':'.$1.'='.$env{$key}; |
my $formitem = $1; |
| |
if ($formitem =~ /^HWFILE(?:SIZE|TOOBIG)/) { |
| |
$what.=':'.$formitem.'='.$env{$key}; |
| |
} elsif ($formitem !~ /^HWFILE(?:[^.]+)$/) { |
| |
$what.=':'.$formitem.'='.$env{$key}; |
| |
} |
| } |
} |
| } |
} |
| } elsif ($fnsymb =~ m:^/adm/searchcat:) { |
} elsif ($fnsymb =~ m:^/adm/searchcat:) { |
|
Line 2455 sub userrolelog {
|
Line 2934 sub userrolelog {
|
| if (($trole=~/^ca/) || ($trole=~/^aa/) || |
if (($trole=~/^ca/) || ($trole=~/^aa/) || |
| ($trole=~/^in/) || ($trole=~/^cc/) || |
($trole=~/^in/) || ($trole=~/^cc/) || |
| ($trole=~/^ep/) || ($trole=~/^cr/) || |
($trole=~/^ep/) || ($trole=~/^cr/) || |
| ($trole=~/^ta/)) { |
($trole=~/^ta/) || ($trole=~/^co/)) { |
| my (undef,$rudom,$runame,$rsec)=split(/\//,$area); |
my (undef,$rudom,$runame,$rsec)=split(/\//,$area); |
| $userrolehash |
$userrolehash |
| {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} |
{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} |
|
Line 2464 sub userrolelog {
|
Line 2943 sub userrolelog {
|
| if (($env{'request.role'} =~ /dc\./) && |
if (($env{'request.role'} =~ /dc\./) && |
| (($trole=~/^au/) || ($trole=~/^in/) || |
(($trole=~/^au/) || ($trole=~/^in/) || |
| ($trole=~/^cc/) || ($trole=~/^ep/) || |
($trole=~/^cc/) || ($trole=~/^ep/) || |
| ($trole=~/^cr/) || ($trole=~/^ta/))) { |
($trole=~/^cr/) || ($trole=~/^ta/) || |
| |
($trole=~/^co/))) { |
| $userrolehash |
$userrolehash |
| {$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'} |
{$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'} |
| =$tend.':'.$tstart; |
=$tend.':'.$tstart; |
|
Line 2480 sub userrolelog {
|
Line 2960 sub userrolelog {
|
| } |
} |
| } |
} |
| |
|
| |
sub courserolelog { |
| |
my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$selfenroll,$context)=@_; |
| |
if (($trole eq 'cc') || ($trole eq 'in') || |
| |
($trole eq 'ep') || ($trole eq 'ad') || |
| |
($trole eq 'ta') || ($trole eq 'st') || |
| |
($trole=~/^cr/) || ($trole eq 'gr') || |
| |
($trole eq 'co')) { |
| |
if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) { |
| |
my $cdom = $1; |
| |
my $cnum = $2; |
| |
my $sec = $3; |
| |
my $namespace = 'rolelog'; |
| |
my %storehash = ( |
| |
role => $trole, |
| |
start => $tstart, |
| |
end => $tend, |
| |
selfenroll => $selfenroll, |
| |
context => $context, |
| |
); |
| |
if ($trole eq 'gr') { |
| |
$namespace = 'groupslog'; |
| |
$storehash{'group'} = $sec; |
| |
} else { |
| |
$storehash{'section'} = $sec; |
| |
} |
| |
&instructor_log($namespace,\%storehash,$delflag,$username,$domain,$cnum,$cdom); |
| |
if (($trole ne 'st') || ($sec ne '')) { |
| |
&devalidate_cache_new('getcourseroles',$cdom.'_'.$cnum); |
| |
} |
| |
} |
| |
} |
| |
return; |
| |
} |
| |
|
| sub get_course_adv_roles { |
sub get_course_adv_roles { |
| my ($cid,$codes) = @_; |
my ($cid,$codes) = @_; |
| $cid=$env{'request.course.id'} unless (defined($cid)); |
$cid=$env{'request.course.id'} unless (defined($cid)); |
| my %coursehash=&coursedescription($cid); |
my %coursehash=&coursedescription($cid); |
| |
my $crstype = &Apache::loncommon::course_type($cid); |
| my %nothide=(); |
my %nothide=(); |
| foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) { |
foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) { |
| if ($user !~ /:/) { |
if ($user !~ /:/) { |
|
Line 2496 sub get_course_adv_roles {
|
Line 3011 sub get_course_adv_roles {
|
| my %dumphash= |
my %dumphash= |
| &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'}); |
&dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'}); |
| my $now=time; |
my $now=time; |
| foreach my $entry (keys %dumphash) { |
my %privileged; |
| |
foreach my $entry (keys(%dumphash)) { |
| my ($tend,$tstart)=split(/\:/,$dumphash{$entry}); |
my ($tend,$tstart)=split(/\:/,$dumphash{$entry}); |
| if (($tstart) && ($tstart<0)) { next; } |
if (($tstart) && ($tstart<0)) { next; } |
| if (($tend) && ($tend<$now)) { next; } |
if (($tend) && ($tend<$now)) { next; } |
| if (($tstart) && ($now<$tstart)) { next; } |
if (($tstart) && ($now<$tstart)) { next; } |
| my ($role,$username,$domain,$section)=split(/\:/,$entry); |
my ($role,$username,$domain,$section)=split(/\:/,$entry); |
| if ($username eq '' || $domain eq '') { next; } |
if ($username eq '' || $domain eq '') { next; } |
| if ((&privileged($username,$domain)) && |
unless (ref($privileged{$domain}) eq 'HASH') { |
| (!$nothide{$username.':'.$domain})) { next; } |
my %dompersonnel = |
| |
&Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now); |
| |
$privileged{$domain} = {}; |
| |
foreach my $server (keys(%dompersonnel)) { |
| |
if (ref($dompersonnel{$server}) eq 'HASH') { |
| |
foreach my $user (keys(%{$dompersonnel{$server}})) { |
| |
my ($trole,$uname,$udom) = split(/:/,$user); |
| |
$privileged{$udom}{$uname} = 1; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
if ((exists($privileged{$domain}{$username})) && |
| |
(!$nothide{$username.':'.$domain})) { next; } |
| if ($role eq 'cr') { next; } |
if ($role eq 'cr') { next; } |
| if ($codes) { |
if ($codes) { |
| if ($section) { $role .= ':'.$section; } |
if ($section) { $role .= ':'.$section; } |
|
Line 2514 sub get_course_adv_roles {
|
Line 3043 sub get_course_adv_roles {
|
| $returnhash{$role}=$username.':'.$domain; |
$returnhash{$role}=$username.':'.$domain; |
| } |
} |
| } else { |
} else { |
| my $key=&plaintext($role); |
my $key=&plaintext($role,$crstype); |
| if ($section) { $key.=' (Section '.$section.')'; } |
if ($section) { $key.=' ('.&Apache::lonlocal::mt('Section [_1]',$section).')'; } |
| if ($returnhash{$key}) { |
if ($returnhash{$key}) { |
| $returnhash{$key}.=','.$username.':'.$domain; |
$returnhash{$key}.=','.$username.':'.$domain; |
| } else { |
} else { |
|
Line 2532 sub get_my_roles {
|
Line 3061 sub get_my_roles {
|
| unless (defined($udom)) { $udom=$env{'user.domain'}; } |
unless (defined($udom)) { $udom=$env{'user.domain'}; } |
| my (%dumphash,%nothide); |
my (%dumphash,%nothide); |
| if ($context eq 'userroles') { |
if ($context eq 'userroles') { |
| %dumphash = &dump('roles',$udom,$uname); |
my $extra = &freeze_escape({'skipcheck' => 1}); |
| |
%dumphash = &dump('roles',$udom,$uname,'.',undef,$extra); |
| } else { |
} else { |
| %dumphash= |
%dumphash= |
| &dump('nohist_userroles',$udom,$uname); |
&dump('nohist_userroles',$udom,$uname); |
|
Line 2549 sub get_my_roles {
|
Line 3079 sub get_my_roles {
|
| } |
} |
| my %returnhash=(); |
my %returnhash=(); |
| my $now=time; |
my $now=time; |
| |
my %privileged; |
| foreach my $entry (keys(%dumphash)) { |
foreach my $entry (keys(%dumphash)) { |
| my ($role,$tend,$tstart); |
my ($role,$tend,$tstart); |
| if ($context eq 'userroles') { |
if ($context eq 'userroles') { |
|
Line 2597 sub get_my_roles {
|
Line 3128 sub get_my_roles {
|
| } |
} |
| } |
} |
| if ($hidepriv) { |
if ($hidepriv) { |
| if ((&privileged($username,$domain)) && |
if ($context eq 'userroles') { |
| (!$nothide{$username.':'.$domain})) { |
if ((&privileged($username,$domain)) && |
| next; |
(!$nothide{$username.':'.$domain})) { |
| |
next; |
| |
} |
| |
} else { |
| |
unless (ref($privileged{$domain}) eq 'HASH') { |
| |
my %dompersonnel = |
| |
&Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now); |
| |
$privileged{$domain} = {}; |
| |
if (keys(%dompersonnel)) { |
| |
foreach my $server (keys(%dompersonnel)) { |
| |
if (ref($dompersonnel{$server}) eq 'HASH') { |
| |
foreach my $user (keys(%{$dompersonnel{$server}})) { |
| |
my ($trole,$uname,$udom) = split(/:/,$user); |
| |
$privileged{$udom}{$uname} = $trole; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
if (exists($privileged{$domain}{$username})) { |
| |
if (!$nothide{$username.':'.$domain}) { |
| |
next; |
| |
} |
| |
} |
| } |
} |
| } |
} |
| if ($withsec) { |
if ($withsec) { |
|
Line 2647 sub getannounce {
|
Line 3201 sub getannounce {
|
| |
|
| sub courseidput { |
sub courseidput { |
| my ($domain,$storehash,$coursehome,$caller) = @_; |
my ($domain,$storehash,$coursehome,$caller) = @_; |
| |
return unless (ref($storehash) eq 'HASH'); |
| my $outcome; |
my $outcome; |
| if ($caller eq 'timeonly') { |
if ($caller eq 'timeonly') { |
| my $cids = ''; |
my $cids = ''; |
|
Line 2685 sub courseidput {
|
Line 3240 sub courseidput {
|
| sub courseiddump { |
sub courseiddump { |
| my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter, |
my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter, |
| $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok, |
$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok, |
| $selfenrollonly)=@_; |
$selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone, |
| |
$cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner)=@_; |
| my $as_hash = 1; |
my $as_hash = 1; |
| my %returnhash; |
my %returnhash; |
| if (!$domfilter) { $domfilter=''; } |
if (!$domfilter) { $domfilter=''; } |
|
Line 2703 sub courseiddump {
|
Line 3259 sub courseiddump {
|
| &escape($instcodefilter).':'.&escape($ownerfilter). |
&escape($instcodefilter).':'.&escape($ownerfilter). |
| ':'.&escape($coursefilter).':'.&escape($typefilter). |
':'.&escape($coursefilter).':'.&escape($typefilter). |
| ':'.&escape($regexp_ok).':'.$as_hash.':'. |
':'.&escape($regexp_ok).':'.$as_hash.':'. |
| &escape($selfenrollonly),$tryserver); |
&escape($selfenrollonly).':'.&escape($catfilter).':'. |
| |
$showhidden.':'.$caller.':'.&escape($cloner).':'. |
| |
&escape($cc_clone).':'.$cloneonly.':'. |
| |
&escape($createdbefore).':'.&escape($createdafter).':'. |
| |
&escape($creationcontext).':'.$domcloner, |
| |
$tryserver); |
| my @pairs=split(/\&/,$rep); |
my @pairs=split(/\&/,$rep); |
| foreach my $item (@pairs) { |
foreach my $item (@pairs) { |
| my ($key,$value)=split(/\=/,$item,2); |
my ($key,$value)=split(/\=/,$item,2); |
|
Line 2718 sub courseiddump {
|
Line 3279 sub courseiddump {
|
| for (my $i=0; $i<@responses; $i++) { |
for (my $i=0; $i<@responses; $i++) { |
| $returnhash{$key}{$items[$i]} = &unescape($responses[$i]); |
$returnhash{$key}{$items[$i]} = &unescape($responses[$i]); |
| } |
} |
| } |
} |
| } |
} |
| } |
} |
| } |
} |
|
Line 2726 sub courseiddump {
|
Line 3287 sub courseiddump {
|
| return %returnhash; |
return %returnhash; |
| } |
} |
| |
|
| |
sub courselastaccess { |
| |
my ($cdom,$cnum,$hostidref) = @_; |
| |
my %returnhash; |
| |
if ($cdom && $cnum) { |
| |
my $chome = &homeserver($cnum,$cdom); |
| |
if ($chome ne 'no_host') { |
| |
my $rep = &reply('courselastaccess:'.$cdom.':'.$cnum,$chome); |
| |
&extract_lastaccess(\%returnhash,$rep); |
| |
} |
| |
} else { |
| |
if (!$cdom) { $cdom=''; } |
| |
my %libserv = &all_library(); |
| |
foreach my $tryserver (keys(%libserv)) { |
| |
if (ref($hostidref) eq 'ARRAY') { |
| |
next unless (grep(/^\Q$tryserver\E$/,@{$hostidref})); |
| |
} |
| |
if (($cdom eq '') || (&host_domain($tryserver) eq $cdom)) { |
| |
my $rep = &reply('courselastaccess:'.&host_domain($tryserver).':',$tryserver); |
| |
&extract_lastaccess(\%returnhash,$rep); |
| |
} |
| |
} |
| |
} |
| |
return %returnhash; |
| |
} |
| |
|
| |
sub extract_lastaccess { |
| |
my ($returnhash,$rep) = @_; |
| |
if (ref($returnhash) eq 'HASH') { |
| |
unless ($rep eq 'unknown_command' || $rep eq 'no_such_host' || |
| |
$rep eq 'con_lost' || $rep eq 'rejected' || $rep eq 'refused' || |
| |
$rep eq '') { |
| |
my @pairs=split(/\&/,$rep); |
| |
foreach my $item (@pairs) { |
| |
my ($key,$value)=split(/\=/,$item,2); |
| |
$key = &unescape($key); |
| |
next if ($key =~ /^error: 2 /); |
| |
$returnhash->{$key} = &thaw_unescape($value); |
| |
} |
| |
} |
| |
} |
| |
return; |
| |
} |
| |
|
| # ---------------------------------------------------------- DC e-mail |
# ---------------------------------------------------------- DC e-mail |
| |
|
| sub dcmailput { |
sub dcmailput { |
|
Line 2758 sub dcmaildump {
|
Line 3362 sub dcmaildump {
|
| |
|
| sub get_domain_roles { |
sub get_domain_roles { |
| my ($dom,$roles,$startdate,$enddate)=@_; |
my ($dom,$roles,$startdate,$enddate)=@_; |
| if (undef($startdate) || $startdate eq '') { |
if ((!defined($startdate)) || ($startdate eq '')) { |
| $startdate = '.'; |
$startdate = '.'; |
| } |
} |
| if (undef($enddate) || $enddate eq '') { |
if ((!defined($enddate)) || ($enddate eq '')) { |
| $enddate = '.'; |
$enddate = '.'; |
| } |
} |
| my $rolelist; |
my $rolelist; |
|
Line 3168 sub tmpreset {
|
Line 3772 sub tmpreset {
|
| if (tie(%hash,'GDBM_File', |
if (tie(%hash,'GDBM_File', |
| $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', |
$path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', |
| &GDBM_WRCREAT(),0640)) { |
&GDBM_WRCREAT(),0640)) { |
| foreach my $key (keys %hash) { |
foreach my $key (keys(%hash)) { |
| if ($key=~ /:$symb/) { |
if ($key=~ /:$symb/) { |
| delete($hash{$key}); |
delete($hash{$key}); |
| } |
} |
|
Line 3445 sub coursedescription {
|
Line 4049 sub coursedescription {
|
| return %returnhash; |
return %returnhash; |
| } |
} |
| |
|
| |
sub update_released_required { |
| |
my ($needsrelease,$cdom,$cnum,$chome,$cid) = @_; |
| |
if ($cdom eq '' || $cnum eq '' || $chome eq '' || $cid eq '') { |
| |
$cid = $env{'request.course.id'}; |
| |
$cdom = $env{'course.'.$cid.'.domain'}; |
| |
$cnum = $env{'course.'.$cid.'.num'}; |
| |
$chome = $env{'course.'.$cid.'.home'}; |
| |
} |
| |
if ($needsrelease) { |
| |
my %curr_reqd_hash = &userenvironment($cdom,$cnum,'internal.releaserequired'); |
| |
my $needsupdate; |
| |
if ($curr_reqd_hash{'internal.releaserequired'} eq '') { |
| |
$needsupdate = 1; |
| |
} else { |
| |
my ($currmajor,$currminor) = split(/\./,$curr_reqd_hash{'internal.releaserequired'}); |
| |
my ($needsmajor,$needsminor) = split(/\./,$needsrelease); |
| |
if (($currmajor < $needsmajor) || ($currmajor == $needsmajor && $currminor < $needsminor)) { |
| |
$needsupdate = 1; |
| |
} |
| |
} |
| |
if ($needsupdate) { |
| |
my %needshash = ( |
| |
'internal.releaserequired' => $needsrelease, |
| |
); |
| |
my $putresult = &put('environment',\%needshash,$cdom,$cnum); |
| |
if ($putresult eq 'ok') { |
| |
&appenv({'course.'.$cid.'.internal.releaserequired' => $needsrelease}); |
| |
my %crsinfo = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,undef,'.'); |
| |
if (ref($crsinfo{$cid}) eq 'HASH') { |
| |
$crsinfo{$cid}{'releaserequired'} = $needsrelease; |
| |
&courseidput($cdom,\%crsinfo,$chome,'notime'); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return; |
| |
} |
| |
|
| # -------------------------------------------------See if a user is privileged |
# -------------------------------------------------See if a user is privileged |
| |
|
| sub privileged { |
sub privileged { |
| my ($username,$domain)=@_; |
my ($username,$domain)=@_; |
| my $rolesdump=&reply("dump:$domain:$username:roles", |
my $rolesdump=&reply("dump:$domain:$username:roles", |
| &homeserver($username,$domain)); |
&homeserver($username,$domain)); |
| if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return 0; } |
if (($rolesdump eq 'con_lost') || ($rolesdump eq '') || |
| |
($rolesdump =~ /^error:/)) { |
| |
return 0; |
| |
} |
| my $now=time; |
my $now=time; |
| if ($rolesdump ne '') { |
if ($rolesdump ne '') { |
| foreach my $entry (split(/&/,$rolesdump)) { |
foreach my $entry (split(/&/,$rolesdump)) { |
|
Line 3479 sub privileged {
|
Line 4124 sub privileged {
|
| |
|
| sub rolesinit { |
sub rolesinit { |
| my ($domain,$username,$authhost)=@_; |
my ($domain,$username,$authhost)=@_; |
| my $rolesdump=reply("dump:$domain:$username:roles",$authhost); |
|
| if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; } |
|
| my %allroles=(); |
|
| my %allgroups=(); |
|
| my $now=time; |
my $now=time; |
| my %userroles = ('user.login.time' => $now); |
my %userroles = ('user.login.time' => $now); |
| |
my $extra = &freeze_escape({'skipcheck' => 1}); |
| |
my $rolesdump=reply("dump:$domain:$username:roles:.::$extra",$authhost); |
| |
if (($rolesdump eq 'con_lost') || ($rolesdump eq '') || |
| |
($rolesdump =~ /^error:/)) { |
| |
return \%userroles; |
| |
} |
| |
my %allroles=(); |
| |
my %allgroups=(); |
| my $group_privs; |
my $group_privs; |
| |
|
| if ($rolesdump ne '') { |
if ($rolesdump ne '') { |
|
Line 3550 sub custom_roleprivs {
|
Line 4199 sub custom_roleprivs {
|
| if (($rdummy ne 'con_lost') && ($roledef ne '')) { |
if (($rdummy ne 'con_lost') && ($roledef ne '')) { |
| my ($syspriv,$dompriv,$coursepriv)=split(/\_/,$roledef); |
my ($syspriv,$dompriv,$coursepriv)=split(/\_/,$roledef); |
| if (defined($syspriv)) { |
if (defined($syspriv)) { |
| |
if ($trest =~ /^$match_community$/) { |
| |
$syspriv =~ s/bre\&S//; |
| |
} |
| $$allroles{'cm./'}.=':'.$syspriv; |
$$allroles{'cm./'}.=':'.$syspriv; |
| $$allroles{$spec.'./'}.=':'.$syspriv; |
$$allroles{$spec.'./'}.=':'.$syspriv; |
| } |
} |
|
Line 3598 sub standard_roleprivs {
|
Line 4250 sub standard_roleprivs {
|
| } |
} |
| |
|
| sub set_userprivs { |
sub set_userprivs { |
| my ($userroles,$allroles,$allgroups) = @_; |
my ($userroles,$allroles,$allgroups,$groups_roles) = @_; |
| my $author=0; |
my $author=0; |
| my $adv=0; |
my $adv=0; |
| my %grouproles = (); |
my %grouproles = (); |
| if (keys(%{$allgroups}) > 0) { |
if (keys(%{$allgroups}) > 0) { |
| foreach my $role (keys %{$allroles}) { |
my @groupkeys; |
| my ($trole,$area,$sec,$extendedarea); |
foreach my $role (keys(%{$allroles})) { |
| if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)\.-) { |
push(@groupkeys,$role); |
| $trole = $1; |
} |
| $area = $2; |
if (ref($groups_roles) eq 'HASH') { |
| $sec = $3; |
foreach my $key (keys(%{$groups_roles})) { |
| $extendedarea = $area.$sec; |
unless (grep(/^\Q$key\E$/,@groupkeys)) { |
| if (exists($$allgroups{$area})) { |
push(@groupkeys,$key); |
| foreach my $group (keys(%{$$allgroups{$area}})) { |
} |
| my $spec = $trole.'.'.$extendedarea; |
} |
| $grouproles{$spec.'.'.$area.'/'.$group} = |
} |
| |
if (@groupkeys > 0) { |
| |
foreach my $role (@groupkeys) { |
| |
my ($trole,$area,$sec,$extendedarea); |
| |
if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)\.-) { |
| |
$trole = $1; |
| |
$area = $2; |
| |
$sec = $3; |
| |
$extendedarea = $area.$sec; |
| |
if (exists($$allgroups{$area})) { |
| |
foreach my $group (keys(%{$$allgroups{$area}})) { |
| |
my $spec = $trole.'.'.$extendedarea; |
| |
$grouproles{$spec.'.'.$area.'/'.$group} = |
| $$allgroups{$area}{$group}; |
$$allgroups{$area}{$group}; |
| |
} |
| } |
} |
| } |
} |
| } |
} |
|
Line 3646 sub set_userprivs {
|
Line 4311 sub set_userprivs {
|
| return ($author,$adv); |
return ($author,$adv); |
| } |
} |
| |
|
| |
sub role_status { |
| |
my ($rolekey,$then,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_; |
| |
my @pwhere = (); |
| |
if (exists($env{$rolekey}) && $env{$rolekey} ne '') { |
| |
(undef,undef,$$role,@pwhere)=split(/\./,$rolekey); |
| |
unless (!defined($$role) || $$role eq '') { |
| |
$$where=join('.',@pwhere); |
| |
$$trolecode=$$role.'.'.$$where; |
| |
($$tstart,$$tend)=split(/\./,$env{$rolekey}); |
| |
$$tstatus='is'; |
| |
if ($$tstart && $$tstart>$then) { |
| |
$$tstatus='future'; |
| |
if ($$tstart<$now) { |
| |
if ($$tstart && $$tstart>$refresh) { |
| |
if (($$where ne '') && ($$role ne '')) { |
| |
my (%allroles,%allgroups,$group_privs, |
| |
%groups_roles,@rolecodes); |
| |
my %userroles = ( |
| |
'user.role.'.$$role.'.'.$$where => $$tstart.'.'.$$tend |
| |
); |
| |
@rolecodes = ('cm'); |
| |
my $spec=$$role.'.'.$$where; |
| |
my ($tdummy,$tdomain,$trest)=split(/\//,$$where); |
| |
if ($$role =~ /^cr\//) { |
| |
&custom_roleprivs(\%allroles,$$role,$tdomain,$trest,$spec,$$where); |
| |
push(@rolecodes,'cr'); |
| |
} elsif ($$role eq 'gr') { |
| |
push(@rolecodes,$$role); |
| |
my %rolehash = &get('roles',[$$where.'_'.$$role],$env{'user.domain'}, |
| |
$env{'user.name'}); |
| |
my ($trole) = split('_',$rolehash{$$where.'_'.$$role},2); |
| |
(undef,my $group_privs) = split(/\//,$trole); |
| |
$group_privs = &unescape($group_privs); |
| |
&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); |
| |
if (keys(%course_roles) > 0) { |
| |
my ($tnum) = ($trest =~ /^($match_courseid)/); |
| |
if ($tdomain ne '' && $tnum ne '') { |
| |
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 { |
| |
push(@rolecodes,$$role); |
| |
&standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where); |
| |
} |
| |
my ($author,$adv)= &set_userprivs(\%userroles,\%allroles,\%allgroups,\%groups_roles); |
| |
&appenv(\%userroles,\@rolecodes); |
| |
&log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role); |
| |
} |
| |
} |
| |
$$tstatus = 'is'; |
| |
} |
| |
} |
| |
if ($$tend) { |
| |
if ($$tend<$then) { |
| |
$$tstatus='expired'; |
| |
} elsif ($$tend<$now) { |
| |
$$tstatus='will_not'; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
|
| |
sub check_adhoc_privs { |
| |
my ($cdom,$cnum,$then,$refresh,$now,$checkrole) = @_; |
| |
my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum; |
| |
if ($env{$cckey}) { |
| |
my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend); |
| |
&role_status($cckey,$then,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend); |
| |
unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) { |
| |
&set_adhoc_privileges($cdom,$cnum,$checkrole); |
| |
} |
| |
} else { |
| |
&set_adhoc_privileges($cdom,$cnum,$checkrole); |
| |
} |
| |
} |
| |
|
| |
sub set_adhoc_privileges { |
| |
# role can be cc or ca |
| |
my ($dcdom,$pickedcourse,$role) = @_; |
| |
my $area = '/'.$dcdom.'/'.$pickedcourse; |
| |
my $spec = $role.'.'.$area; |
| |
my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'}, |
| |
$env{'user.name'}); |
| |
my %ccrole = (); |
| |
&standard_roleprivs(\%ccrole,$role,$dcdom,$spec,$pickedcourse,$area); |
| |
my ($author,$adv)= &set_userprivs(\%userroles,\%ccrole); |
| |
&appenv(\%userroles,[$role,'cm']); |
| |
&log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role); |
| |
&appenv( {'request.role' => $spec, |
| |
'request.role.domain' => $dcdom, |
| |
'request.course.sec' => '' |
| |
} |
| |
); |
| |
my $tadv=0; |
| |
if (&allowed('adv') eq 'F') { $tadv=1; } |
| |
&appenv({'request.role.adv' => $tadv}); |
| |
} |
| |
|
| # --------------------------------------------------------------- get interface |
# --------------------------------------------------------------- get interface |
| |
|
| sub get { |
sub get { |
|
Line 3681 sub del {
|
Line 4466 sub del {
|
| foreach my $item (@$storearr) { |
foreach my $item (@$storearr) { |
| $items.=&escape($item).'&'; |
$items.=&escape($item).'&'; |
| } |
} |
| |
|
| $items=~s/\&$//; |
$items=~s/\&$//; |
| if (!$udomain) { $udomain=$env{'user.domain'}; } |
if (!$udomain) { $udomain=$env{'user.domain'}; } |
| if (!$uname) { $uname=$env{'user.name'}; } |
if (!$uname) { $uname=$env{'user.name'}; } |
| my $uhome=&homeserver($uname,$udomain); |
my $uhome=&homeserver($uname,$udomain); |
| |
|
| return &reply("del:$udomain:$uname:$namespace:$items",$uhome); |
return &reply("del:$udomain:$uname:$namespace:$items",$uhome); |
| } |
} |
| |
|
| # -------------------------------------------------------------- dump interface |
# -------------------------------------------------------------- dump interface |
| |
|
| sub dump { |
sub dump { |
| my ($namespace,$udomain,$uname,$regexp,$range)=@_; |
my ($namespace,$udomain,$uname,$regexp,$range,$extra)=@_; |
| if (!$udomain) { $udomain=$env{'user.domain'}; } |
if (!$udomain) { $udomain=$env{'user.domain'}; } |
| if (!$uname) { $uname=$env{'user.name'}; } |
if (!$uname) { $uname=$env{'user.name'}; } |
| my $uhome=&homeserver($uname,$udomain); |
my $uhome=&homeserver($uname,$udomain); |
|
Line 3701 sub dump {
|
Line 4486 sub dump {
|
| } else { |
} else { |
| $regexp='.'; |
$regexp='.'; |
| } |
} |
| my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome); |
my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range:$extra",$uhome); |
| my @pairs=split(/\&/,$rep); |
my @pairs=split(/\&/,$rep); |
| my %returnhash=(); |
my %returnhash=(); |
| foreach my $item (@pairs) { |
foreach my $item (@pairs) { |
|
Line 4106 sub get_portfolio_access {
|
Line 4891 sub get_portfolio_access {
|
| my (%allgroups,%allroles); |
my (%allgroups,%allroles); |
| my ($start,$end,$role,$sec,$group); |
my ($start,$end,$role,$sec,$group); |
| foreach my $envkey (%env) { |
foreach my $envkey (%env) { |
| if ($envkey =~ m-^user\.role\.(gr|cc|in|ta|ep|st)\./($match_domain)/($match_courseid)/?([^/]*)$-) { |
if ($envkey =~ m-^user\.role\.(gr|cc|co|in|ta|ep|ad|st)\./($match_domain)/($match_courseid)/?([^/]*)$-) { |
| my $cid = $2.'_'.$3; |
my $cid = $2.'_'.$3; |
| if ($1 eq 'gr') { |
if ($1 eq 'gr') { |
| $group = $4; |
$group = $4; |
|
Line 4245 sub is_portfolio_file {
|
Line 5030 sub is_portfolio_file {
|
| return; |
return; |
| } |
} |
| |
|
| |
sub usertools_access { |
| |
my ($uname,$udom,$tool,$action,$context,$userenvref,$domdefref,$is_advref) = @_; |
| |
my ($access,%tools); |
| |
if ($context eq '') { |
| |
$context = 'tools'; |
| |
} |
| |
if ($context eq 'requestcourses') { |
| |
%tools = ( |
| |
official => 1, |
| |
unofficial => 1, |
| |
community => 1, |
| |
); |
| |
} else { |
| |
%tools = ( |
| |
aboutme => 1, |
| |
blog => 1, |
| |
portfolio => 1, |
| |
); |
| |
} |
| |
return if (!defined($tools{$tool})); |
| |
|
| |
if ((!defined($udom)) || (!defined($uname))) { |
| |
$udom = $env{'user.domain'}; |
| |
$uname = $env{'user.name'}; |
| |
} |
| |
|
| |
if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { |
| |
if ($action ne 'reload') { |
| |
if ($context eq 'requestcourses') { |
| |
return $env{'environment.canrequest.'.$tool}; |
| |
} else { |
| |
return $env{'environment.availabletools.'.$tool}; |
| |
} |
| |
} |
| |
} |
| |
|
| |
my ($toolstatus,$inststatus); |
| |
|
| |
if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) && |
| |
($action ne 'reload')) { |
| |
$toolstatus = $env{'environment.'.$context.'.'.$tool}; |
| |
$inststatus = $env{'environment.inststatus'}; |
| |
} else { |
| |
if (ref($userenvref) eq 'HASH') { |
| |
$toolstatus = $userenvref->{$context.'.'.$tool}; |
| |
$inststatus = $userenvref->{'inststatus'}; |
| |
} else { |
| |
my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool,'inststatus'); |
| |
$toolstatus = $userenv{$context.'.'.$tool}; |
| |
$inststatus = $userenv{'inststatus'}; |
| |
} |
| |
} |
| |
|
| |
if ($toolstatus ne '') { |
| |
if ($toolstatus) { |
| |
$access = 1; |
| |
} else { |
| |
$access = 0; |
| |
} |
| |
return $access; |
| |
} |
| |
|
| |
my ($is_adv,%domdef); |
| |
if (ref($is_advref) eq 'HASH') { |
| |
$is_adv = $is_advref->{'is_adv'}; |
| |
} else { |
| |
$is_adv = &is_advanced_user($udom,$uname); |
| |
} |
| |
if (ref($domdefref) eq 'HASH') { |
| |
%domdef = %{$domdefref}; |
| |
} else { |
| |
%domdef = &get_domain_defaults($udom); |
| |
} |
| |
if (ref($domdef{$tool}) eq 'HASH') { |
| |
if ($is_adv) { |
| |
if ($domdef{$tool}{'_LC_adv'} ne '') { |
| |
if ($domdef{$tool}{'_LC_adv'}) { |
| |
$access = 1; |
| |
} else { |
| |
$access = 0; |
| |
} |
| |
return $access; |
| |
} |
| |
} |
| |
if ($inststatus ne '') { |
| |
my ($hasaccess,$hasnoaccess); |
| |
foreach my $affiliation (split(/:/,$inststatus)) { |
| |
if ($domdef{$tool}{$affiliation} ne '') { |
| |
if ($domdef{$tool}{$affiliation}) { |
| |
$hasaccess = 1; |
| |
} else { |
| |
$hasnoaccess = 1; |
| |
} |
| |
} |
| |
} |
| |
if ($hasaccess || $hasnoaccess) { |
| |
if ($hasaccess) { |
| |
$access = 1; |
| |
} elsif ($hasnoaccess) { |
| |
$access = 0; |
| |
} |
| |
return $access; |
| |
} |
| |
} else { |
| |
if ($domdef{$tool}{'default'} ne '') { |
| |
if ($domdef{$tool}{'default'}) { |
| |
$access = 1; |
| |
} elsif ($domdef{$tool}{'default'} == 0) { |
| |
$access = 0; |
| |
} |
| |
return $access; |
| |
} |
| |
} |
| |
} else { |
| |
if ($context eq 'tools') { |
| |
$access = 1; |
| |
} else { |
| |
$access = 0; |
| |
} |
| |
return $access; |
| |
} |
| |
} |
| |
|
| |
sub is_course_owner { |
| |
my ($cdom,$cnum,$udom,$uname) = @_; |
| |
if (($udom eq '') || ($uname eq '')) { |
| |
$udom = $env{'user.domain'}; |
| |
$uname = $env{'user.name'}; |
| |
} |
| |
unless (($udom eq '') || ($uname eq '')) { |
| |
if (exists($env{'course.'.$cdom.'_'.$cnum.'.internal.courseowner'})) { |
| |
if ($env{'course.'.$cdom.'_'.$cnum.'.internal.courseowner'} eq $uname.':'.$udom) { |
| |
return 1; |
| |
} else { |
| |
my %courseinfo = &Apache::lonnet::coursedescription($cdom.'/'.$cnum); |
| |
if ($courseinfo{'internal.courseowner'} eq $uname.':'.$udom) { |
| |
return 1; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return; |
| |
} |
| |
|
| |
sub is_advanced_user { |
| |
my ($udom,$uname) = @_; |
| |
if ($udom ne '' && $uname ne '') { |
| |
if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { |
| |
return $env{'user.adv'}; |
| |
} |
| |
} |
| |
my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1); |
| |
my %allroles; |
| |
my $is_adv; |
| |
foreach my $role (keys(%roleshash)) { |
| |
my ($trest,$tdomain,$trole,$sec) = split(/:/,$role); |
| |
my $area = '/'.$tdomain.'/'.$trest; |
| |
if ($sec ne '') { |
| |
$area .= '/'.$sec; |
| |
} |
| |
if (($area ne '') && ($trole ne '')) { |
| |
my $spec=$trole.'.'.$area; |
| |
if ($trole =~ /^cr\//) { |
| |
&custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area); |
| |
} elsif ($trole ne 'gr') { |
| |
&standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area); |
| |
} |
| |
} |
| |
} |
| |
foreach my $role (keys(%allroles)) { |
| |
last if ($is_adv); |
| |
foreach my $item (split(/:/,$allroles{$role})) { |
| |
if ($item ne '') { |
| |
my ($privilege,$restrictions)=split(/&/,$item); |
| |
if ($privilege eq 'adv') { |
| |
$is_adv = 1; |
| |
last; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return $is_adv; |
| |
} |
| |
|
| |
sub check_can_request { |
| |
my ($dom,$can_request,$request_domains) = @_; |
| |
my $canreq = 0; |
| |
my ($types,$typename) = &Apache::loncommon::course_types(); |
| |
my @options = ('approval','validate','autolimit'); |
| |
my $optregex = join('|',@options); |
| |
if ((ref($can_request) eq 'HASH') && (ref($types) eq 'ARRAY')) { |
| |
foreach my $type (@{$types}) { |
| |
if (&usertools_access($env{'user.name'}, |
| |
$env{'user.domain'}, |
| |
$type,undef,'requestcourses')) { |
| |
$canreq ++; |
| |
if (ref($request_domains) eq 'HASH') { |
| |
push(@{$request_domains->{$type}},$env{'user.domain'}); |
| |
} |
| |
if ($dom eq $env{'user.domain'}) { |
| |
$can_request->{$type} = 1; |
| |
} |
| |
} |
| |
if ($env{'environment.reqcrsotherdom.'.$type} ne '') { |
| |
my @curr = split(',',$env{'environment.reqcrsotherdom.'.$type}); |
| |
if (@curr > 0) { |
| |
foreach my $item (@curr) { |
| |
if (ref($request_domains) eq 'HASH') { |
| |
my ($otherdom) = ($item =~ /^($match_domain):($optregex)(=?\d*)$/); |
| |
if ($otherdom ne '') { |
| |
if (ref($request_domains->{$type}) eq 'ARRAY') { |
| |
unless (grep(/^\Q$otherdom\E$/,@{$request_domains->{$type}})) { |
| |
push(@{$request_domains->{$type}},$otherdom); |
| |
} |
| |
} else { |
| |
push(@{$request_domains->{$type}},$otherdom); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
unless($dom eq $env{'user.domain'}) { |
| |
$canreq ++; |
| |
if (grep(/^\Q$dom\E:($optregex)(=?\d*)$/,@curr)) { |
| |
$can_request->{$type} = 1; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return $canreq; |
| |
} |
| |
|
| # ---------------------------------------------- Custom access rule evaluation |
# ---------------------------------------------- Custom access rule evaluation |
| |
|
|
Line 4400 sub allowed {
|
Line 5417 sub allowed {
|
| my $statecond=0; |
my $statecond=0; |
| my $courseprivid=''; |
my $courseprivid=''; |
| |
|
| |
my $ownaccess; |
| |
# Community Coordinator or Assistant Co-author browsing resource space. |
| |
if (($priv eq 'bro') && ($env{'user.author'})) { |
| |
if ($uri eq '') { |
| |
$ownaccess = 1; |
| |
} else { |
| |
if (($env{'user.domain'} ne '') && ($env{'user.name'} ne '')) { |
| |
my $udom = $env{'user.domain'}; |
| |
my $uname = $env{'user.name'}; |
| |
if ($uri =~ m{^\Q$udom\E/?$}) { |
| |
$ownaccess = 1; |
| |
} elsif ($uri =~ m{^\Q$udom\E/\Q$uname\E/?}) { |
| |
unless ($uri =~ m{\.\./}) { |
| |
$ownaccess = 1; |
| |
} |
| |
} elsif (($udom ne 'public') && ($uname ne 'public')) { |
| |
my $now = time; |
| |
if ($uri =~ m{^([^/]+)/?$}) { |
| |
my $adom = $1; |
| |
foreach my $key (keys(%env)) { |
| |
if ($key =~ m{^user\.role\.(ca|aa)/\Q$adom\E}) { |
| |
my ($start,$end) = split('.',$env{$key}); |
| |
if (($now >= $start) && (!$end || $end < $now)) { |
| |
$ownaccess = 1; |
| |
last; |
| |
} |
| |
} |
| |
} |
| |
} elsif ($uri =~ m{^([^/]+)/([^/]+)/?}) { |
| |
my $adom = $1; |
| |
my $aname = $2; |
| |
foreach my $role ('ca','aa') { |
| |
if ($env{"user.role.$role./$adom/$aname"}) { |
| |
my ($start,$end) = |
| |
split('.',$env{"user.role.$role./$adom/$aname"}); |
| |
if (($now >= $start) && (!$end || $end < $now)) { |
| |
$ownaccess = 1; |
| |
last; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
|
| # Course |
# Course |
| |
|
| if ($env{'user.priv.'.$env{'request.role'}.'./'}=~/\Q$priv\E\&([^\:]*)/) { |
if ($env{'user.priv.'.$env{'request.role'}.'./'}=~/\Q$priv\E\&([^\:]*)/) { |
| $thisallowed.=$1; |
unless (($priv eq 'bro') && (!$ownaccess)) { |
| |
$thisallowed.=$1; |
| |
} |
| } |
} |
| |
|
| # Domain |
# Domain |
| |
|
| if ($env{'user.priv.'.$env{'request.role'}.'./'.(split(/\//,$uri))[0].'/'} |
if ($env{'user.priv.'.$env{'request.role'}.'./'.(split(/\//,$uri))[0].'/'} |
| =~/\Q$priv\E\&([^\:]*)/) { |
=~/\Q$priv\E\&([^\:]*)/) { |
| $thisallowed.=$1; |
unless (($priv eq 'bro') && (!$ownaccess)) { |
| |
$thisallowed.=$1; |
| |
} |
| } |
} |
| |
|
| # Course: uri itself is a course |
# Course: uri itself is a course |
|
Line 4420 sub allowed {
|
Line 5488 sub allowed {
|
| |
|
| if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseuri} |
if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseuri} |
| =~/\Q$priv\E\&([^\:]*)/) { |
=~/\Q$priv\E\&([^\:]*)/) { |
| $thisallowed.=$1; |
unless (($priv eq 'bro') && (!$ownaccess)) { |
| |
$thisallowed.=$1; |
| |
} |
| } |
} |
| |
|
| # URI is an uploaded document for this course, default permissions don't matter |
# URI is an uploaded document for this course, default permissions don't matter |
|
Line 4457 sub allowed {
|
Line 5527 sub allowed {
|
| } |
} |
| |
|
| # Full access at system, domain or course-wide level? Exit. |
# Full access at system, domain or course-wide level? Exit. |
| |
|
| if ($thisallowed=~/F/) { |
if ($thisallowed=~/F/) { |
| return 'F'; |
return 'F'; |
| } |
} |
|
Line 4561 sub allowed {
|
Line 5630 sub allowed {
|
| |
|
| my $envkey; |
my $envkey; |
| if ($thisallowed=~/L/) { |
if ($thisallowed=~/L/) { |
| foreach $envkey (keys %env) { |
foreach $envkey (keys(%env)) { |
| if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) { |
if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) { |
| my $courseid=$2; |
my $courseid=$2; |
| my $roleid=$1.'.'.$2; |
my $roleid=$1.'.'.$2; |
|
Line 4810 sub log_query {
|
Line 5879 sub log_query {
|
| |
|
| sub update_portfolio_table { |
sub update_portfolio_table { |
| my ($uname,$udom,$file_name,$query,$group,$action) = @_; |
my ($uname,$udom,$file_name,$query,$group,$action) = @_; |
| |
if ($group ne '') { |
| |
$file_name =~s /^\Q$group\E//; |
| |
} |
| my $homeserver = &homeserver($uname,$udom); |
my $homeserver = &homeserver($uname,$udom); |
| my $queryid= |
my $queryid= |
| &reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group). |
&reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group). |
|
Line 4831 sub update_allusers_table {
|
Line 5903 sub update_allusers_table {
|
| 'generation='.&escape($names->{'generation'}).'%%'. |
'generation='.&escape($names->{'generation'}).'%%'. |
| 'permanentemail='.&escape($names->{'permanentemail'}).'%%'. |
'permanentemail='.&escape($names->{'permanentemail'}).'%%'. |
| 'id='.&escape($names->{'id'}),$homeserver); |
'id='.&escape($names->{'id'}),$homeserver); |
| my $reply = &get_query_reply($queryid); |
return; |
| return $reply; |
|
| } |
} |
| |
|
| # ------- Request retrieval of institutional classlists for course(s) |
# ------- Request retrieval of institutional classlists for course(s) |
|
Line 4849 sub fetch_enrollment_query {
|
Line 5920 sub fetch_enrollment_query {
|
| } |
} |
| my $host=&hostname($homeserver); |
my $host=&hostname($homeserver); |
| my $cmd = ''; |
my $cmd = ''; |
| foreach my $affiliate (keys %{$affiliatesref}) { |
foreach my $affiliate (keys(%{$affiliatesref})) { |
| $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%'; |
$cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%'; |
| } |
} |
| $cmd =~ s/%%$//; |
$cmd =~ s/%%$//; |
|
Line 4982 sub auto_run {
|
Line 6053 sub auto_run {
|
| |
|
| 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; |
| my @secs = (); |
if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) { |
| my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver)); |
$homeserver = &homeserver($cnum,$cdom); |
| unless ($response eq 'refused') { |
} |
| @secs = split(/:/,$response); |
if (!defined($homeserver)) { |
| |
if ($cdom =~ /^$match_domain$/) { |
| |
$homeserver = &domain($cdom,'primary'); |
| |
} |
| |
} |
| |
my @secs; |
| |
if (defined($homeserver)) { |
| |
my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver)); |
| |
unless ($response eq 'refused') { |
| |
@secs = split(/:/,$response); |
| |
} |
| } |
} |
| return @secs; |
return @secs; |
| } |
} |
|
Line 5005 sub auto_validate_courseID {
|
Line 6086 sub auto_validate_courseID {
|
| return $response; |
return $response; |
| } |
} |
| |
|
| |
sub auto_validate_instcode { |
| |
my ($cnum,$cdom,$instcode,$owner) = @_; |
| |
my ($homeserver,$response); |
| |
if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) { |
| |
$homeserver = &homeserver($cnum,$cdom); |
| |
} |
| |
if (!defined($homeserver)) { |
| |
if ($cdom =~ /^$match_domain$/) { |
| |
$homeserver = &domain($cdom,'primary'); |
| |
} |
| |
} |
| |
$response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'. |
| |
&escape($instcode).':'.&escape($owner),$homeserver)); |
| |
my ($outcome,$description) = map { &unescape($_); } split('&',$response,2); |
| |
return ($outcome,$description); |
| |
} |
| |
|
| sub auto_create_password { |
sub auto_create_password { |
| my ($cnum,$cdom,$authparam,$udom) = @_; |
my ($cnum,$cdom,$authparam,$udom) = @_; |
| my ($homeserver,$response); |
my ($homeserver,$response); |
|
Line 5119 sub auto_instcode_format {
|
Line 6217 sub auto_instcode_format {
|
| push(@homeservers,$tryserver); |
push(@homeservers,$tryserver); |
| } |
} |
| } |
} |
| |
} elsif ($caller eq 'requests') { |
| |
if ($codedom =~ /^$match_domain$/) { |
| |
my $chome = &domain($codedom,'primary'); |
| |
unless ($chome eq 'no_host') { |
| |
push(@homeservers,$chome); |
| |
} |
| |
} |
| } else { |
} else { |
| push(@homeservers,&homeserver($caller,$codedom)); |
push(@homeservers,&homeserver($caller,$codedom)); |
| } |
} |
|
Line 5176 sub auto_instcode_defaults {
|
Line 6281 sub auto_instcode_defaults {
|
| } |
} |
| |
|
| return $response; |
return $response; |
| } |
} |
| |
|
| |
sub auto_possible_instcodes { |
| |
my ($domain,$codetitles,$cat_titles,$cat_orders,$code_order) = @_; |
| |
unless ((ref($codetitles) eq 'ARRAY') && (ref($cat_titles) eq 'HASH') && |
| |
(ref($cat_orders) eq 'HASH') && (ref($code_order) eq 'ARRAY')) { |
| |
return; |
| |
} |
| |
my (@homeservers,$uhome); |
| |
if (defined(&domain($domain,'primary'))) { |
| |
$uhome=&domain($domain,'primary'); |
| |
push(@homeservers,&domain($domain,'primary')); |
| |
} else { |
| |
my %servers = &get_servers($domain,'library'); |
| |
foreach my $tryserver (keys(%servers)) { |
| |
if (!grep(/^\Q$tryserver\E$/,@homeservers)) { |
| |
push(@homeservers,$tryserver); |
| |
} |
| |
} |
| |
} |
| |
my $response; |
| |
foreach my $server (@homeservers) { |
| |
$response=&reply('autopossibleinstcodes:'.$domain,$server); |
| |
next if ($response =~ /(con_lost|error|no_such_host|refused)/); |
| |
my ($codetitlestr,$codeorderstr,$cat_title,$cat_order) = |
| |
split(':',$response); |
| |
@{$codetitles} = map { &unescape($_); } (split('&',$codetitlestr)); |
| |
@{$code_order} = map { &unescape($_); } (split('&',$codeorderstr)); |
| |
foreach my $item (split('&',$cat_title)) { |
| |
my ($name,$value)=split('=',$item); |
| |
$cat_titles->{&unescape($name)}=&thaw_unescape($value); |
| |
} |
| |
foreach my $item (split('&',$cat_order)) { |
| |
my ($name,$value)=split('=',$item); |
| |
$cat_orders->{&unescape($name)}=&thaw_unescape($value); |
| |
} |
| |
return 'ok'; |
| |
} |
| |
return $response; |
| |
} |
| |
|
| |
sub auto_courserequest_checks { |
| |
my ($dom) = @_; |
| |
my ($homeserver,%validations); |
| |
if ($dom =~ /^$match_domain$/) { |
| |
$homeserver = &domain($dom,'primary'); |
| |
} |
| |
unless ($homeserver eq 'no_host') { |
| |
my $response=&reply('autocrsreqchecks:'.$dom,$homeserver); |
| |
unless ($response =~ /(con_lost|error|no_such_host|refused)/) { |
| |
my @items = split(/&/,$response); |
| |
foreach my $item (@items) { |
| |
my ($key,$value) = split('=',$item); |
| |
$validations{&unescape($key)} = &thaw_unescape($value); |
| |
} |
| |
} |
| |
} |
| |
return %validations; |
| |
} |
| |
|
| |
sub auto_courserequest_validation { |
| |
my ($dom,$owner,$crstype,$inststatuslist,$instcode,$instseclist) = @_; |
| |
my ($homeserver,$response); |
| |
if ($dom =~ /^$match_domain$/) { |
| |
$homeserver = &domain($dom,'primary'); |
| |
} |
| |
unless ($homeserver eq 'no_host') { |
| |
|
| |
$response=&unescape(&reply('autocrsreqvalidation:'.$dom.':'.&escape($owner). |
| |
':'.&escape($crstype).':'.&escape($inststatuslist). |
| |
':'.&escape($instcode).':'.&escape($instseclist), |
| |
$homeserver)); |
| |
} |
| |
return $response; |
| |
} |
| |
|
| sub auto_validate_class_sec { |
sub auto_validate_class_sec { |
| my ($cdom,$cnum,$owners,$inst_class) = @_; |
my ($cdom,$cnum,$owners,$inst_class) = @_; |
|
Line 5236 sub toggle_coursegroup_status {
|
Line 6415 sub toggle_coursegroup_status {
|
| } |
} |
| |
|
| sub modify_group_roles { |
sub modify_group_roles { |
| my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs) = @_; |
my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs,$selfenroll,$context) = @_; |
| my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id; |
my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id; |
| my $role = 'gr/'.&escape($userprivs); |
my $role = 'gr/'.&escape($userprivs); |
| my ($uname,$udom) = split(/:/,$user); |
my ($uname,$udom) = split(/:/,$user); |
| my $result = &assignrole($udom,$uname,$url,$role,$end,$start); |
my $result = &assignrole($udom,$uname,$url,$role,$end,$start,'',$selfenroll,$context); |
| if ($result eq 'ok') { |
if ($result eq 'ok') { |
| &devalidate_getgroups_cache($udom,$uname,$cdom,$cnum); |
&devalidate_getgroups_cache($udom,$uname,$cdom,$cnum); |
| } |
} |
|
Line 5287 sub get_users_groups {
|
Line 6466 sub get_users_groups {
|
| } else { |
} else { |
| $grouplist = ''; |
$grouplist = ''; |
| my $courseurl = &courseid_to_courseurl($courseid); |
my $courseurl = &courseid_to_courseurl($courseid); |
| my %roleshash = &dump('roles',$udom,$uname,$courseurl); |
my $extra = &freeze_escape({'skipcheck' => 1}); |
| |
my %roleshash = &dump('roles',$udom,$uname,$courseurl,undef,$extra); |
| my $access_end = $env{'course.'.$courseid. |
my $access_end = $env{'course.'.$courseid. |
| '.default_enrollment_end_date'}; |
'.default_enrollment_end_date'}; |
| my $now = time; |
my $now = time; |
|
Line 5329 sub devalidate_getgroups_cache {
|
Line 6509 sub devalidate_getgroups_cache {
|
| # ------------------------------------------------------------------ Plain Text |
# ------------------------------------------------------------------ Plain Text |
| |
|
| sub plaintext { |
sub plaintext { |
| my ($short,$type,$cid) = @_; |
my ($short,$type,$cid,$forcedefault) = @_; |
| if ($short =~ /^cr/) { |
if ($short =~ m{^cr/}) { |
| return (split('/',$short))[-1]; |
return (split('/',$short))[-1]; |
| } |
} |
| if (!defined($cid)) { |
if (!defined($cid)) { |
| $cid = $env{'request.course.id'}; |
$cid = $env{'request.course.id'}; |
| } |
} |
| if (defined($cid) && defined($env{'course.'.$cid.'.'.$short.'.plaintext'})) { |
|
| return &Apache::lonlocal::mt($env{'course.'.$cid.'.'.$short. |
|
| '.plaintext'}); |
|
| } |
|
| my %rolenames = ( |
my %rolenames = ( |
| Course => 'std', |
Course => 'std', |
| Group => 'alt1', |
Community => 'alt1', |
| ); |
); |
| if (defined($type) && |
if ($cid ne '') { |
| defined($rolenames{$type}) && |
if ($env{'course.'.$cid.'.'.$short.'.plaintext'} ne '') { |
| defined($prp{$short}{$rolenames{$type}})) { |
unless ($forcedefault) { |
| |
my $roletext = $env{'course.'.$cid.'.'.$short.'.plaintext'}; |
| |
&Apache::lonlocal::mt_escape(\$roletext); |
| |
return &Apache::lonlocal::mt($roletext); |
| |
} |
| |
} |
| |
} |
| |
if ((defined($type)) && (defined($rolenames{$type})) && |
| |
(defined($rolenames{$type})) && |
| |
(defined($prp{$short}{$rolenames{$type}}))) { |
| return &Apache::lonlocal::mt($prp{$short}{$rolenames{$type}}); |
return &Apache::lonlocal::mt($prp{$short}{$rolenames{$type}}); |
| } else { |
} elsif ($cid ne '') { |
| return &Apache::lonlocal::mt($prp{$short}{'std'}); |
my $crstype = $env{'course.'.$cid.'.type'}; |
| |
if (($crstype ne '') && (defined($rolenames{$crstype})) && |
| |
(defined($prp{$short}{$rolenames{$crstype}}))) { |
| |
return &Apache::lonlocal::mt($prp{$short}{$rolenames{$crstype}}); |
| |
} |
| } |
} |
| |
return &Apache::lonlocal::mt($prp{$short}{'std'}); |
| } |
} |
| |
|
| # ----------------------------------------------------------------- Assign Role |
# ----------------------------------------------------------------- Assign Role |
| |
|
| sub assignrole { |
sub assignrole { |
| my ($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll)=@_; |
my ($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll, |
| |
$context)=@_; |
| my $mrole; |
my $mrole; |
| if ($role =~ /^cr\//) { |
if ($role =~ /^cr\//) { |
| my $cwosec=$url; |
my $cwosec=$url; |
| $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/; |
$cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/; |
| unless (&allowed('ccr',$cwosec)) { |
unless (&allowed('ccr',$cwosec)) { |
| &logthis('Refused custom assignrole: '. |
my $refused = 1; |
| $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. |
if ($context eq 'requestcourses') { |
| $env{'user.name'}.' at '.$env{'user.domain'}); |
if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) { |
| return 'refused'; |
if ($role =~ m{^cr/($match_domain)/($match_username)/([^/]+)$}) { |
| |
if (($1 eq $env{'user.domain'}) && ($2 eq $env{'user.name'})) { |
| |
my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$}); |
| |
my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner')); |
| |
if ($crsenv{'internal.courseowner'} eq |
| |
$env{'user.name'}.':'.$env{'user.domain'}) { |
| |
$refused = ''; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
if ($refused) { |
| |
&logthis('Refused custom assignrole: '. |
| |
$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start. |
| |
' by '.$env{'user.name'}.' at '.$env{'user.domain'}); |
| |
return 'refused'; |
| |
} |
| } |
} |
| $mrole='cr'; |
$mrole='cr'; |
| } elsif ($role =~ /^gr\//) { |
} elsif ($role =~ /^gr\//) { |
|
Line 5391 sub assignrole {
|
Line 6599 sub assignrole {
|
| $refused = 1; |
$refused = 1; |
| } |
} |
| if ($refused) { |
if ($refused) { |
| if (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { |
my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$}); |
| |
if (!$selfenroll && $context eq 'course') { |
| |
my %crsenv; |
| |
if ($role eq 'cc' || $role eq 'co') { |
| |
%crsenv = &userenvironment($cdom,$cnum,('internal.courseowner')); |
| |
if (($role eq 'cc') && ($cnum !~ /^$match_community$/)) { |
| |
if ($env{'request.role'} eq 'cc./'.$cdom.'/'.$cnum) { |
| |
if ($crsenv{'internal.courseowner'} eq |
| |
$env{'user.name'}.':'.$env{'user.domain'}) { |
| |
$refused = ''; |
| |
} |
| |
} |
| |
} elsif (($role eq 'co') && ($cnum =~ /^$match_community$/)) { |
| |
if ($env{'request.role'} eq 'co./'.$cdom.'/'.$cnum) { |
| |
if ($crsenv{'internal.courseowner'} eq |
| |
$env{'user.name'}.':'.$env{'user.domain'}) { |
| |
$refused = ''; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} elsif (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { |
| $refused = ''; |
$refused = ''; |
| } else { |
} elsif ($context eq 'requestcourses') { |
| |
my @possroles = ('st','ta','ep','in','cc','co'); |
| |
if ((grep(/^\Q$role\E$/,@possroles)) && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) { |
| |
my $wrongcc; |
| |
if ($cnum =~ /^$match_community$/) { |
| |
$wrongcc = 1 if ($role eq 'cc'); |
| |
} else { |
| |
$wrongcc = 1 if ($role eq 'co'); |
| |
} |
| |
unless ($wrongcc) { |
| |
my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner')); |
| |
if ($crsenv{'internal.courseowner'} eq |
| |
$env{'user.name'}.':'.$env{'user.domain'}) { |
| |
$refused = ''; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
if ($refused) { |
| &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url. |
&logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url. |
| ' '.$role.' '.$end.' '.$start.' by '. |
' '.$role.' '.$end.' '.$start.' by '. |
| $env{'user.name'}.' at '.$env{'user.domain'}); |
$env{'user.name'}.' at '.$env{'user.domain'}); |
|
Line 5415 sub assignrole {
|
Line 6662 sub assignrole {
|
| } |
} |
| my $origstart = $start; |
my $origstart = $start; |
| my $origend = $end; |
my $origend = $end; |
| |
my $delflag; |
| # actually delete |
# actually delete |
| if ($deleteflag) { |
if ($deleteflag) { |
| if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) { |
if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) { |
|
Line 5425 sub assignrole {
|
Line 6673 sub assignrole {
|
| # set start and finish to negative values for userrolelog |
# set start and finish to negative values for userrolelog |
| $start=-1; |
$start=-1; |
| $end=-1; |
$end=-1; |
| |
$delflag = 1; |
| } |
} |
| } |
} |
| # send command |
# send command |
|
Line 5433 sub assignrole {
|
Line 6682 sub assignrole {
|
| if ($answer eq 'ok') { |
if ($answer eq 'ok') { |
| &userrolelog($role,$uname,$udom,$url,$start,$end); |
&userrolelog($role,$uname,$udom,$url,$start,$end); |
| # for course roles, perform group memberships changes triggered by role change. |
# for course roles, perform group memberships changes triggered by role change. |
| |
&courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,$selfenroll,$context); |
| unless ($role =~ /^gr/) { |
unless ($role =~ /^gr/) { |
| &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend, |
&Apache::longroup::group_changes($udom,$uname,$url,$role,$origend, |
| $origstart); |
$origstart,$selfenroll,$context); |
| |
} |
| |
if ($role eq 'cc') { |
| |
&autoupdate_coowners($url,$end,$start,$uname,$udom); |
| } |
} |
| } |
} |
| return $answer; |
return $answer; |
| } |
} |
| |
|
| |
sub autoupdate_coowners { |
| |
my ($url,$end,$start,$uname,$udom) = @_; |
| |
my ($cdom,$cnum) = ($url =~ m{^/($match_domain)/($match_courseid)}); |
| |
if (($cdom ne '') && ($cnum ne '')) { |
| |
my $now = time; |
| |
my %domdesign = &Apache::loncommon::get_domainconf($cdom); |
| |
if ($domdesign{$cdom.'.autoassign.co-owners'}) { |
| |
my %coursehash = &coursedescription($cdom.'_'.$cnum); |
| |
my $instcode = $coursehash{'internal.coursecode'}; |
| |
if ($instcode ne '') { |
| |
if (($start && $start <= $now) && ($end == 0) || ($end > $now)) { |
| |
unless ($coursehash{'internal.courseowner'} eq $uname.':'.$udom) { |
| |
my ($delcoowners,@newcoowners,$putresult,$delresult,$coowners); |
| |
my ($result,$desc) = &auto_validate_instcode($cnum,$cdom,$instcode,$uname.':'.$udom); |
| |
if ($result eq 'valid') { |
| |
if ($coursehash{'internal.co-owners'}) { |
| |
foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) { |
| |
push(@newcoowners,$coowner); |
| |
} |
| |
unless (grep(/^\Q$uname\E:\Q$udom\E$/,@newcoowners)) { |
| |
push(@newcoowners,$uname.':'.$udom); |
| |
} |
| |
@newcoowners = sort(@newcoowners); |
| |
} else { |
| |
push(@newcoowners,$uname.':'.$udom); |
| |
} |
| |
} else { |
| |
if ($coursehash{'internal.co-owners'}) { |
| |
foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) { |
| |
unless ($coowner eq $uname.':'.$udom) { |
| |
push(@newcoowners,$coowner); |
| |
} |
| |
} |
| |
unless (@newcoowners > 0) { |
| |
$delcoowners = 1; |
| |
$coowners = ''; |
| |
} |
| |
} |
| |
} |
| |
if (@newcoowners || $delcoowners) { |
| |
&store_coowners($cdom,$cnum,$coursehash{'home'}, |
| |
$delcoowners,@newcoowners); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
|
| |
sub store_coowners { |
| |
my ($cdom,$cnum,$chome,$delcoowners,@newcoowners) = @_; |
| |
my $cid = $cdom.'_'.$cnum; |
| |
my ($coowners,$delresult,$putresult); |
| |
if (@newcoowners) { |
| |
$coowners = join(',',@newcoowners); |
| |
my %coownershash = ( |
| |
'internal.co-owners' => $coowners, |
| |
); |
| |
$putresult = &put('environment',\%coownershash,$cdom,$cnum); |
| |
if ($putresult eq 'ok') { |
| |
if ($env{'course.'.$cid.'.num'} eq $cnum) { |
| |
&appenv({'course.'.$cid.'.internal.co-owners' => $coowners}); |
| |
} |
| |
} |
| |
} |
| |
if ($delcoowners) { |
| |
$delresult = &Apache::lonnet::del('environment',['internal.co-owners'],$cdom,$cnum); |
| |
if ($delresult eq 'ok') { |
| |
if ($env{'course.'.$cid.'.internal.co-owners'}) { |
| |
&Apache::lonnet::delenv('course.'.$cid.'.internal.co-owners'); |
| |
} |
| |
} |
| |
} |
| |
if (($putresult eq 'ok') || ($delresult eq 'ok')) { |
| |
my %crsinfo = |
| |
&Apache::lonnet::courseiddump($cdom,'.',1,'.','.',$cnum,undef,undef,'.'); |
| |
if (ref($crsinfo{$cid}) eq 'HASH') { |
| |
$crsinfo{$cid}{'co-owners'} = \@newcoowners; |
| |
my $cidput = &Apache::lonnet::courseidput($cdom,\%crsinfo,$chome,'notime'); |
| |
} |
| |
} |
| |
} |
| |
|
| # -------------------------------------------------- Modify user authentication |
# -------------------------------------------------- Modify user authentication |
| # Overrides without validation |
# Overrides without validation |
| |
|
|
Line 5473 sub modifyuser {
|
Line 6810 sub modifyuser {
|
| my ($udom, $uname, $uid, |
my ($udom, $uname, $uid, |
| $umode, $upass, $first, |
$umode, $upass, $first, |
| $middle, $last, $gene, |
$middle, $last, $gene, |
| $forceid, $desiredhome, $email)=@_; |
$forceid, $desiredhome, $email, $inststatus, $candelete)=@_; |
| $udom= &LONCAPA::clean_domain($udom); |
$udom= &LONCAPA::clean_domain($udom); |
| $uname=&LONCAPA::clean_username($uname); |
$uname=&LONCAPA::clean_username($uname); |
| |
my $showcandelete = 'none'; |
| |
if (ref($candelete) eq 'ARRAY') { |
| |
if (@{$candelete} > 0) { |
| |
$showcandelete = join(', ',@{$candelete}); |
| |
} |
| |
} |
| &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. |
&logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. |
| $umode.', '.$first.', '.$middle.', '. |
$umode.', '.$first.', '.$middle.', '. |
| $last.', '.$gene.'(forceid: '.$forceid.')'. |
$last.', '.$gene.'(forceid: '.$forceid.'; candelete: '.$showcandelete.')'. |
| (defined($desiredhome) ? ' desiredhome = '.$desiredhome : |
(defined($desiredhome) ? ' desiredhome = '.$desiredhome : |
| ' desiredhome not specified'). |
' desiredhome not specified'). |
| ' by '.$env{'user.name'}.' at '.$env{'user.domain'}. |
' by '.$env{'user.name'}.' at '.$env{'user.domain'}. |
| ' in domain '.$env{'request.role.domain'}); |
' in domain '.$env{'request.role.domain'}); |
| my $uhome=&homeserver($uname,$udom,'true'); |
my $uhome=&homeserver($uname,$udom,'true'); |
| |
my $newuser; |
| |
if ($uhome eq 'no_host') { |
| |
$newuser = 1; |
| |
} |
| # ----------------------------------------------------------------- Create User |
# ----------------------------------------------------------------- Create User |
| if (($uhome eq 'no_host') && |
if (($uhome eq 'no_host') && |
| (($umode && $upass) || ($umode eq 'localauth'))) { |
(($umode && $upass) || ($umode eq 'localauth'))) { |
|
Line 5534 sub modifyuser {
|
Line 6881 sub modifyuser {
|
| # -------------------------------------------------------------- Add names, etc |
# -------------------------------------------------------------- Add names, etc |
| my @tmp=&get('environment', |
my @tmp=&get('environment', |
| ['firstname','middlename','lastname','generation','id', |
['firstname','middlename','lastname','generation','id', |
| 'permanentemail'], |
'permanentemail','inststatus'], |
| $udom,$uname); |
$udom,$uname); |
| my %names; |
my (%names,%oldnames); |
| if ($tmp[0] =~ m/^error:.*/) { |
if ($tmp[0] =~ m/^error:.*/) { |
| %names=(); |
%names=(); |
| } else { |
} else { |
| %names = @tmp; |
%names = @tmp; |
| |
%oldnames = %names; |
| } |
} |
| # |
# |
| # Make sure to not trash student environment if instructor does not bother |
# If name, email and/or uid are blank (e.g., because an uploaded file |
| # to supply name and email information |
# of users did not contain them), do not overwrite existing values |
| # |
# unless field is in $candelete array ref. |
| |
# |
| |
|
| |
my @fields = ('firstname','middlename','lastname','generation', |
| |
'permanentemail','id'); |
| |
my %newvalues; |
| |
if (ref($candelete) eq 'ARRAY') { |
| |
foreach my $field (@fields) { |
| |
if (grep(/^\Q$field\E$/,@{$candelete})) { |
| |
if ($field eq 'firstname') { |
| |
$names{$field} = $first; |
| |
} elsif ($field eq 'middlename') { |
| |
$names{$field} = $middle; |
| |
} elsif ($field eq 'lastname') { |
| |
$names{$field} = $last; |
| |
} elsif ($field eq 'generation') { |
| |
$names{$field} = $gene; |
| |
} elsif ($field eq 'permanentemail') { |
| |
$names{$field} = $email; |
| |
} elsif ($field eq 'id') { |
| |
$names{$field} = $uid; |
| |
} |
| |
} |
| |
} |
| |
} |
| if ($first) { $names{'firstname'} = $first; } |
if ($first) { $names{'firstname'} = $first; } |
| if (defined($middle)) { $names{'middlename'} = $middle; } |
if (defined($middle)) { $names{'middlename'} = $middle; } |
| if ($last) { $names{'lastname'} = $last; } |
if ($last) { $names{'lastname'} = $last; } |
| if (defined($gene)) { $names{'generation'} = $gene; } |
if (defined($gene)) { $names{'generation'} = $gene; } |
| if ($email) { |
if ($email) { |
| $email=~s/[^\w\@\.\-\,]//gs; |
$email=~s/[^\w\@\.\-\,]//gs; |
| if ($email=~/\@/) { $names{'notification'} = $email; |
if ($email=~/\@/) { $names{'permanentemail'} = $email; } |
| $names{'critnotification'} = $email; |
|
| $names{'permanentemail'} = $email; } |
|
| } |
} |
| if ($uid) { $names{'id'} = $uid; } |
if ($uid) { $names{'id'} = $uid; } |
| |
if (defined($inststatus)) { |
| |
$names{'inststatus'} = ''; |
| |
my ($usertypes,$typesorder) = &retrieve_inst_usertypes($udom); |
| |
if (ref($usertypes) eq 'HASH') { |
| |
my @okstatuses; |
| |
foreach my $item (split(/:/,$inststatus)) { |
| |
if (defined($usertypes->{$item})) { |
| |
push(@okstatuses,$item); |
| |
} |
| |
} |
| |
if (@okstatuses) { |
| |
$names{'inststatus'} = join(':', map { &escape($_); } @okstatuses); |
| |
} |
| |
} |
| |
} |
| |
my $logmsg = $udom.', '.$uname.', '.$uid.', '. |
| |
$umode.', '.$first.', '.$middle.', '. |
| |
$last.', '.$gene.', '.$email.', '.$inststatus; |
| |
if ($env{'user.name'} ne '' && $env{'user.domain'}) { |
| |
$logmsg .= ' by '.$env{'user.name'}.' at '.$env{'user.domain'}; |
| |
} else { |
| |
$logmsg .= ' during self creation'; |
| |
} |
| |
my $changed; |
| |
if ($newuser) { |
| |
$changed = 1; |
| |
} else { |
| |
foreach my $field (@fields) { |
| |
if ($names{$field} ne $oldnames{$field}) { |
| |
$changed = 1; |
| |
last; |
| |
} |
| |
} |
| |
} |
| |
unless ($changed) { |
| |
$logmsg = 'No changes in user information needed for: '.$logmsg; |
| |
&logthis($logmsg); |
| |
return 'ok'; |
| |
} |
| my $reply = &put('environment', \%names, $udom,$uname); |
my $reply = &put('environment', \%names, $udom,$uname); |
| if ($reply ne 'ok') { return 'error: '.$reply; } |
if ($reply ne 'ok') { |
| |
return 'error: '.$reply; |
| |
} |
| |
if ($names{'permanentemail'} ne $oldnames{'permanentemail'}) { |
| |
&Apache::lonnet::devalidate_cache_new('emailscache',$uname.':'.$udom); |
| |
} |
| my $sqlresult = &update_allusers_table($uname,$udom,\%names); |
my $sqlresult = &update_allusers_table($uname,$udom,\%names); |
| &devalidate_cache_new('namescache',$uname.':'.$udom); |
&devalidate_cache_new('namescache',$uname.':'.$udom); |
| &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '. |
$logmsg = 'Success modifying user '.$logmsg; |
| $umode.', '.$first.', '.$middle.', '. |
&logthis($logmsg); |
| $last.', '.$gene.' by '. |
|
| $env{'user.name'}.' at '.$env{'user.domain'}); |
|
| return 'ok'; |
return 'ok'; |
| } |
} |
| |
|
|
Line 5572 sub modifyuser {
|
Line 6984 sub modifyuser {
|
| |
|
| sub modifystudent { |
sub modifystudent { |
| my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, |
my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, |
| $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid)=@_; |
$end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid, |
| |
$selfenroll,$context,$inststatus)=@_; |
| if (!$cid) { |
if (!$cid) { |
| unless ($cid=$env{'request.course.id'}) { |
unless ($cid=$env{'request.course.id'}) { |
| return 'not_in_class'; |
return 'not_in_class'; |
|
Line 5581 sub modifystudent {
|
Line 6994 sub modifystudent {
|
| # --------------------------------------------------------------- Make the user |
# --------------------------------------------------------------- Make the user |
| my $reply=&modifyuser |
my $reply=&modifyuser |
| ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid, |
($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid, |
| $desiredhome,$email); |
$desiredhome,$email,$inststatus); |
| unless ($reply eq 'ok') { return $reply; } |
unless ($reply eq 'ok') { return $reply; } |
| # This will cause &modify_student_enrollment to get the uid from the |
# This will cause &modify_student_enrollment to get the uid from the |
| # students environment |
# students environment |
| $uid = undef if (!$forceid); |
$uid = undef if (!$forceid); |
| $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last, |
$reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last, |
| $gene,$usec,$end,$start,$type,$locktype,$cid); |
$gene,$usec,$end,$start,$type,$locktype,$cid,$selfenroll,$context); |
| return $reply; |
return $reply; |
| } |
} |
| |
|
| sub modify_student_enrollment { |
sub modify_student_enrollment { |
| my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid,$selfenroll) = @_; |
my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid,$selfenroll,$context) = @_; |
| my ($cdom,$cnum,$chome); |
my ($cdom,$cnum,$chome); |
| if (!$cid) { |
if (!$cid) { |
| unless ($cid=$env{'request.course.id'}) { |
unless ($cid=$env{'request.course.id'}) { |
|
Line 5650 sub modify_student_enrollment {
|
Line 7063 sub modify_student_enrollment {
|
| if ($usec) { |
if ($usec) { |
| $uurl.='/'.$usec; |
$uurl.='/'.$usec; |
| } |
} |
| return &assignrole($udom,$uname,$uurl,'st',$end,$start,undef,$selfenroll); |
return &assignrole($udom,$uname,$uurl,'st',$end,$start,undef,$selfenroll,$context); |
| } |
} |
| |
|
| sub format_name { |
sub format_name { |
|
Line 5695 sub writecoursepref {
|
Line 7108 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)=@_; |
$course_owner,$crstype,$cnum,$context,$category)=@_; |
| $url=&declutter($url); |
$url=&declutter($url); |
| my $cid=''; |
my $cid=''; |
| unless (&allowed('ccc',$udom)) { |
if ($context eq 'requestcourses') { |
| |
my $can_create = 0; |
| |
my ($ownername,$ownerdom) = split(':',$course_owner); |
| |
if ($udom eq $ownerdom) { |
| |
if (&usertools_access($ownername,$ownerdom,$category,undef, |
| |
$context)) { |
| |
$can_create = 1; |
| |
} |
| |
} else { |
| |
my %userenv = &userenvironment($ownerdom,$ownername,'reqcrsotherdom.'. |
| |
$category); |
| |
if ($userenv{'reqcrsotherdom.'.$category} ne '') { |
| |
my @curr = split(',',$userenv{'reqcrsotherdom.'.$category}); |
| |
if (@curr > 0) { |
| |
my @options = qw(approval validate autolimit); |
| |
my $optregex = join('|',@options); |
| |
if (grep(/^\Q$udom\E:($optregex)(=?\d*)$/,@curr)) { |
| |
$can_create = 1; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
if ($can_create) { |
| |
unless ($ownername eq $env{'user.name'} && $ownerdom eq $env{'user.domain'}) { |
| |
unless (&allowed('ccc',$udom)) { |
| |
return 'refused'; |
| |
} |
| |
} |
| |
} else { |
| |
return 'refused'; |
| |
} |
| |
} elsif (!&allowed('ccc',$udom)) { |
| return 'refused'; |
return 'refused'; |
| } |
} |
| # ------------------------------------------------------------------- Create ID |
# --------------------------------------------------------------- Get Unique ID |
| my $uname=int(1+rand(9)). |
my $uname; |
| ('a'..'z','A'..'Z','0'..'9')[int(rand(62))]. |
if ($cnum =~ /^$match_courseid$/) { |
| substr($$.time,0,5).unpack("H8",pack("I32",time)). |
my $chome=&homeserver($cnum,$udom,'true'); |
| unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; |
if (($chome eq '') || ($chome eq 'no_host')) { |
| # ----------------------------------------------- Make sure that does not exist |
$uname = $cnum; |
| my $uhome=&homeserver($uname,$udom,'true'); |
} else { |
| unless (($uhome eq '') || ($uhome eq 'no_host')) { |
$uname = &generate_coursenum($udom,$crstype); |
| $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)). |
} |
| unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; |
} else { |
| $uhome=&homeserver($uname,$udom,'true'); |
$uname = &generate_coursenum($udom,$crstype); |
| unless (($uhome eq '') || ($uhome eq 'no_host')) { |
} |
| return 'error: unable to generate unique course-ID'; |
return $uname if ($uname =~ /^error/); |
| } |
# -------------------------------------------------- Check supplied server name |
| } |
if (!defined($course_server)) { |
| # ------------------------------------------------ Check supplied server name |
if (defined(&domain($udom,'primary'))) { |
| $course_server = $env{'user.homeserver'} if (! defined($course_server)); |
$course_server = &domain($udom,'primary'); |
| if (! &is_library($course_server)) { |
} else { |
| return 'error:bad server name '.$course_server; |
$course_server = $env{'user.home'}; |
| |
} |
| |
} |
| |
my %host_servers = |
| |
&Apache::lonnet::get_servers($udom,'library'); |
| |
unless ($host_servers{$course_server}) { |
| |
return 'error: invalid home server for course: '.$course_server; |
| } |
} |
| # ------------------------------------------------------------- Make the course |
# ------------------------------------------------------------- Make the course |
| my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::', |
my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::', |
| $course_server); |
$course_server); |
| unless ($reply eq 'ok') { return 'error: '.$reply; } |
unless ($reply eq 'ok') { return 'error: '.$reply; } |
| $uhome=&homeserver($uname,$udom,'true'); |
my $uhome=&homeserver($uname,$udom,'true'); |
| if (($uhome eq '') || ($uhome eq 'no_host')) { |
if (($uhome eq '') || ($uhome eq 'no_host')) { |
| return 'error: no such course'; |
return 'error: no such course'; |
| } |
} |
| # ----------------------------------------------------------------- Course made |
# ----------------------------------------------------------------- Course made |
| # log existence |
# log existence |
| |
my $now = time; |
| my $newcourse = { |
my $newcourse = { |
| $udom.'_'.$uname => { |
$udom.'_'.$uname => { |
| description => $description, |
description => $description, |
| inst_code => $inst_code, |
inst_code => $inst_code, |
| owner => $course_owner, |
owner => $course_owner, |
| type => $crstype, |
type => $crstype, |
| |
creator => $env{'user.name'}.':'. |
| |
$env{'user.domain'}, |
| |
created => $now, |
| |
context => $context, |
| }, |
}, |
| }; |
}; |
| &courseidput($udom,$newcourse,$uhome,'notime'); |
&courseidput($udom,$newcourse,$uhome,'notime'); |
|
Line 5761 ENDINITMAP
|
Line 7216 ENDINITMAP
|
| } |
} |
| # ----------------------------------------------------------- Write preferences |
# ----------------------------------------------------------- Write preferences |
| &writecoursepref($udom.'_'.$uname, |
&writecoursepref($udom.'_'.$uname, |
| ('description' => $description, |
('description' => $description, |
| 'url' => $topurl)); |
'url' => $topurl, |
| |
'internal.creator' => $env{'user.name'}.':'. |
| |
$env{'user.domain'}, |
| |
'internal.created' => $now, |
| |
'internal.creationcontext' => $context) |
| |
); |
| return '/'.$udom.'/'.$uname; |
return '/'.$udom.'/'.$uname; |
| } |
} |
| |
|
| |
# ------------------------------------------------------------------- Create ID |
| |
sub generate_coursenum { |
| |
my ($udom,$crstype) = @_; |
| |
my $domdesc = &domain($udom); |
| |
return 'error: invalid domain' if ($domdesc eq ''); |
| |
my $first; |
| |
if ($crstype eq 'Community') { |
| |
$first = '0'; |
| |
} else { |
| |
$first = int(1+rand(9)); |
| |
} |
| |
my $uname=$first. |
| |
('a'..'z','A'..'Z','0'..'9')[int(rand(62))]. |
| |
substr($$.time,0,5).unpack("H8",pack("I32",time)). |
| |
unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; |
| |
# ----------------------------------------------- Make sure that does not exist |
| |
my $uhome=&homeserver($uname,$udom,'true'); |
| |
unless (($uhome eq '') || ($uhome eq 'no_host')) { |
| |
if ($crstype eq 'Community') { |
| |
$first = '0'; |
| |
} else { |
| |
$first = int(1+rand(9)); |
| |
} |
| |
$uname=$first. |
| |
('a'..'z','A'..'Z','0'..'9')[int(rand(62))]. |
| |
substr($$.time,0,5).unpack("H8",pack("I32",time)). |
| |
unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; |
| |
$uhome=&homeserver($uname,$udom,'true'); |
| |
unless (($uhome eq '') || ($uhome eq 'no_host')) { |
| |
return 'error: unable to generate unique course-ID'; |
| |
} |
| |
} |
| |
return $uname; |
| |
} |
| |
|
| sub is_course { |
sub is_course { |
| my ($cdom,$cnum) = @_; |
my ($cdom,$cnum) = @_; |
| my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef, |
my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef, |
|
Line 5776 sub is_course {
|
Line 7271 sub is_course {
|
| return 0; |
return 0; |
| } |
} |
| |
|
| |
sub store_userdata { |
| |
my ($storehash,$datakey,$namespace,$udom,$uname) = @_; |
| |
my $result; |
| |
if ($datakey ne '') { |
| |
if (ref($storehash) eq 'HASH') { |
| |
if ($udom eq '' || $uname eq '') { |
| |
$udom = $env{'user.domain'}; |
| |
$uname = $env{'user.name'}; |
| |
} |
| |
my $uhome=&homeserver($uname,$udom); |
| |
if (($uhome eq '') || ($uhome eq 'no_host')) { |
| |
$result = 'error: no_host'; |
| |
} else { |
| |
$storehash->{'ip'} = $ENV{'REMOTE_ADDR'}; |
| |
$storehash->{'host'} = $perlvar{'lonHostID'}; |
| |
|
| |
my $namevalue=''; |
| |
foreach my $key (keys(%{$storehash})) { |
| |
$namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&'; |
| |
} |
| |
$namevalue=~s/\&$//; |
| |
$result = &reply("store:$env{'user.domain'}:$env{'user.name'}:". |
| |
"$namespace:$datakey:$namevalue",$uhome); |
| |
} |
| |
} else { |
| |
$result = 'error: data to store was not a hash reference'; |
| |
} |
| |
} else { |
| |
$result= 'error: invalid requestkey'; |
| |
} |
| |
return $result; |
| |
} |
| |
|
| # ---------------------------------------------------------- Assign Custom Role |
# ---------------------------------------------------------- Assign Custom Role |
| |
|
| sub assigncustomrole { |
sub assigncustomrole { |
| my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag)=@_; |
my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag,$selfenroll,$context)=@_; |
| return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename, |
return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename, |
| $end,$start,$deleteflag); |
$end,$start,$deleteflag,$selfenroll,$context); |
| } |
} |
| |
|
| # ----------------------------------------------------------------- Revoke Role |
# ----------------------------------------------------------------- Revoke Role |
| |
|
| sub revokerole { |
sub revokerole { |
| my ($udom,$uname,$url,$role,$deleteflag)=@_; |
my ($udom,$uname,$url,$role,$deleteflag,$selfenroll,$context)=@_; |
| my $now=time; |
my $now=time; |
| return &assignrole($udom,$uname,$url,$role,$now,$deleteflag); |
return &assignrole($udom,$uname,$url,$role,$now,undef,$deleteflag,$selfenroll,$context); |
| } |
} |
| |
|
| # ---------------------------------------------------------- Revoke Custom Role |
# ---------------------------------------------------------- Revoke Custom Role |
| |
|
| sub revokecustomrole { |
sub revokecustomrole { |
| my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag)=@_; |
my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag,$selfenroll,$context)=@_; |
| my $now=time; |
my $now=time; |
| return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now, |
return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now, |
| $deleteflag); |
$deleteflag,$selfenroll,$context); |
| } |
} |
| |
|
| # ------------------------------------------------------------ Disk usage |
# ------------------------------------------------------------ Disk usage |
|
Line 6054 sub modify_access_controls {
|
Line 7582 sub modify_access_controls {
|
| } |
} |
| } |
} |
| } |
} |
| |
my ($group); |
| |
if (&is_course($domain,$user)) { |
| |
($group,my $file) = split(/\//,$file_name,2); |
| |
} |
| $deloutcome = &del('file_permissions',\@deletions,$domain,$user); |
$deloutcome = &del('file_permissions',\@deletions,$domain,$user); |
| $new_values{$file_name."\0".'accesscontrol'} = \%new_control; |
$new_values{$file_name."\0".'accesscontrol'} = \%new_control; |
| $outcome = &put('file_permissions',\%new_values,$domain,$user); |
$outcome = &put('file_permissions',\%new_values,$domain,$user); |
| # remove lock |
# remove lock |
| my @del_lock = ($file_name."\0".'locked_access_records'); |
my @del_lock = ($file_name."\0".'locked_access_records'); |
| my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user); |
my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user); |
| my ($file,$group); |
|
| if (&is_course($domain,$user)) { |
|
| ($group,$file) = split(/\//,$file_name,2); |
|
| } else { |
|
| $file = $file_name; |
|
| } |
|
| my $sqlresult = |
my $sqlresult = |
| &update_portfolio_table($user,$domain,$file,'portfolio_access', |
&update_portfolio_table($user,$domain,$file_name,'portfolio_access', |
| $group); |
$group); |
| } else { |
} else { |
| $outcome = "error: could not obtain lockfile\n"; |
$outcome = "error: could not obtain lockfile\n"; |
|
Line 6264 sub dirlist {
|
Line 7790 sub dirlist {
|
| if($udom) { |
if($udom) { |
| if($uname) { |
if($uname) { |
| $listing = &reply('ls3:'.&escape('/'.$uri).':'.$getpropath.':' |
$listing = &reply('ls3:'.&escape('/'.$uri).':'.$getpropath.':' |
| .$getuserdir.':'.&escape($alternateRoot) |
.$getuserdir.':'.&escape($dirRoot) |
| .':'.&escape($uname).':'.&escape($udom), |
.':'.&escape($uname).':'.&escape($udom), |
| &homeserver($uname,$udom)); |
&homeserver($uname,$udom)); |
| if ($listing eq 'unknown_cmd') { |
if ($listing eq 'unknown_cmd') { |
|
Line 6371 sub stat_file {
|
Line 7897 sub stat_file {
|
| # unable to handle the uri |
# unable to handle the uri |
| return (); |
return (); |
| } |
} |
| |
my $getpropath; |
| my $getpropath = 1; |
if ($file =~ /^userfiles\//) { |
| |
$getpropath = 1; |
| |
} |
| my ($result) = &dirlist($file,$udom,$uname,$getpropath); |
my ($result) = &dirlist($file,$udom,$uname,$getpropath); |
| my @stats = split('&', $result); |
my @stats = split('&', $result); |
| |
|
|
Line 7119 sub metadata {
|
Line 8647 sub metadata {
|
| } |
} |
| } |
} |
| } else { |
} else { |
| |
|
| if (defined($token->[2]->{'name'})) { |
if (defined($token->[2]->{'name'})) { |
| $unikey.='_'.$token->[2]->{'name'}; |
$unikey.='_'.$token->[2]->{'name'}; |
| } |
} |
|
Line 7265 sub devalidate_title_cache {
|
Line 8792 sub devalidate_title_cache {
|
| &devalidate_cache_new('title',$key); |
&devalidate_cache_new('title',$key); |
| } |
} |
| |
|
| |
# ------------------------------------------------- Get the title of a course |
| |
|
| |
sub current_course_title { |
| |
return $env{ 'course.' . $env{'request.course.id'} . '.description' }; |
| |
} |
| # ------------------------------------------------- Get the title of a resource |
# ------------------------------------------------- Get the title of a resource |
| |
|
| sub gettitle { |
sub gettitle { |
|
Line 7331 sub symblist {
|
Line 8863 sub symblist {
|
| if (($env{'request.course.fn'}) && (%newhash)) { |
if (($env{'request.course.fn'}) && (%newhash)) { |
| if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db', |
if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db', |
| &GDBM_WRCREAT(),0640)) { |
&GDBM_WRCREAT(),0640)) { |
| foreach my $url (keys %newhash) { |
foreach my $url (keys(%newhash)) { |
| next if ($url eq 'last_known' |
next if ($url eq 'last_known' |
| && $env{'form.no_update_last_known'}); |
&& $env{'form.no_update_last_known'}); |
| $hash{declutter($url)}=&encode_symb($mapname, |
$hash{declutter($url)}=&encode_symb($mapname, |
|
Line 7368 sub symbverify {
|
Line 8900 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)) { |
| |
if (($thisurl =~ m{^/adm/wrapper/ext/}) || ($thisurl =~ m{^ext/})) { |
| |
$thisurl =~ s/\?.+$//; |
| |
} |
| my $ids=$bighash{'ids_'.&clutter($thisurl)}; |
my $ids=$bighash{'ids_'.&clutter($thisurl)}; |
| unless ($ids) { |
unless ($ids) { |
| $ids=$bighash{'ids_/'.$thisurl}; |
$ids=$bighash{'ids_/'.$thisurl}; |
|
Line 7376 sub symbverify {
|
Line 8911 sub symbverify {
|
| # ------------------------------------------------------------------- Has ID(s) |
# ------------------------------------------------------------------- Has ID(s) |
| foreach my $id (split(/\,/,$ids)) { |
foreach my $id (split(/\,/,$ids)) { |
| my ($mapid,$resid)=split(/\./,$id); |
my ($mapid,$resid)=split(/\./,$id); |
| |
if ($thisfn =~ m{^/adm/wrapper/ext/}) { |
| |
$symb =~ s/\?.+$//; |
| |
} |
| if ( |
if ( |
| &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn) |
&symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn) |
| eq $symb) { |
eq $symb) { |
|
Line 8038 sub repcopy_userfile {
|
Line 9576 sub repcopy_userfile {
|
| if (-e $transferfile) { return 'ok'; } |
if (-e $transferfile) { return 'ok'; } |
| my $request; |
my $request; |
| $uri=~s/^\///; |
$uri=~s/^\///; |
| $request=new HTTP::Request('GET','http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri); |
my $homeserver = &homeserver($cnum,$cdom); |
| |
my $protocol = $protocol{$homeserver}; |
| |
$protocol = 'http' if ($protocol ne 'https'); |
| |
$request=new HTTP::Request('GET',$protocol.'://'.&hostname($homeserver).'/raw/'.$uri); |
| my $response=$ua->request($request,$transferfile); |
my $response=$ua->request($request,$transferfile); |
| # did it work? |
# did it work? |
| if ($response->is_error()) { |
if ($response->is_error()) { |
|
Line 8053 sub repcopy_userfile {
|
Line 9594 sub repcopy_userfile {
|
| |
|
| sub tokenwrapper { |
sub tokenwrapper { |
| my $uri=shift; |
my $uri=shift; |
| $uri=~s|^http\://([^/]+)||; |
$uri=~s|^https?\://([^/]+)||; |
| $uri=~s|^/||; |
$uri=~s|^/||; |
| $env{'user.environment'}=~/\/([^\/]+)\.id/; |
$env{'user.environment'}=~/\/([^\/]+)\.id/; |
| my $token=$1; |
my $token=$1; |
|
Line 8061 sub tokenwrapper {
|
Line 9602 sub tokenwrapper {
|
| if ($udom && $uname && $file) { |
if ($udom && $uname && $file) { |
| $file=~s|(\?\.*)*$||; |
$file=~s|(\?\.*)*$||; |
| &appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}}); |
&appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}}); |
| return 'http://'.&hostname(&homeserver($uname,$udom)).'/'.$uri. |
my $homeserver = &homeserver($uname,$udom); |
| |
my $protocol = $protocol{$homeserver}; |
| |
$protocol = 'http' if ($protocol ne 'https'); |
| |
return $protocol.'://'.&hostname($homeserver).'/'.$uri. |
| (($uri=~/\?/)?'&':'?').'token='.$token. |
(($uri=~/\?/)?'&':'?').'token='.$token. |
| '&tokenissued='.$perlvar{'lonHostID'}; |
'&tokenissued='.$perlvar{'lonHostID'}; |
| } else { |
} else { |
|
Line 8076 sub tokenwrapper {
|
Line 9620 sub tokenwrapper {
|
| sub getuploaded { |
sub getuploaded { |
| my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_; |
my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_; |
| $uri=~s/^\///; |
$uri=~s/^\///; |
| $uri = 'http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri; |
my $homeserver = &homeserver($cnum,$cdom); |
| |
my $protocol = $protocol{$homeserver}; |
| |
$protocol = 'http' if ($protocol ne 'https'); |
| |
$uri = $protocol.'://'.&hostname($homeserver).'/raw/'.$uri; |
| my $ua=new LWP::UserAgent; |
my $ua=new LWP::UserAgent; |
| my $request=new HTTP::Request($reqtype,$uri); |
my $request=new HTTP::Request($reqtype,$uri); |
| my $response=$ua->request($request); |
my $response=$ua->request($request); |
|
Line 8118 sub filelocation {
|
Line 9665 sub filelocation {
|
| } elsif ($file=~m{^/home/$match_username/public_html/}) { |
} elsif ($file=~m{^/home/$match_username/public_html/}) { |
| # is a correct contruction space reference |
# is a correct contruction space reference |
| $location = $file; |
$location = $file; |
| |
} elsif ($file =~ m-^\Q$Apache::lonnet::perlvar{'lonTabDir'}\E/-) { |
| |
$location = $file; |
| } elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file |
} elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file |
| my ($udom,$uname,$filename)= |
my ($udom,$uname,$filename)= |
| ($file=~m -^/+(?:uploaded|editupload)/+($match_domain)/+($match_name)/+(.*)$-); |
($file=~m -^/+(?:uploaded|editupload)/+($match_domain)/+($match_name)/+(.*)$-); |
|
Line 8156 sub filelocation {
|
Line 9705 sub filelocation {
|
| |
|
| sub hreflocation { |
sub hreflocation { |
| my ($dir,$file)=@_; |
my ($dir,$file)=@_; |
| unless (($file=~m-^http://-i) || ($file=~m-^/-)) { |
unless (($file=~m-^https?\://-i) || ($file=~m-^/-)) { |
| $file=filelocation($dir,$file); |
$file=filelocation($dir,$file); |
| } elsif ($file=~m-^/adm/-) { |
} elsif ($file=~m-^/adm/-) { |
| $file=~s-^/adm/wrapper/-/-; |
$file=~s-^/adm/wrapper/-/-; |
|
Line 8241 sub declutter {
|
Line 9790 sub declutter {
|
| $thisfn=~s|^adm/wrapper/||; |
$thisfn=~s|^adm/wrapper/||; |
| $thisfn=~s|^adm/coursedocs/showdoc/||; |
$thisfn=~s|^adm/coursedocs/showdoc/||; |
| $thisfn=~s/^res\///; |
$thisfn=~s/^res\///; |
| $thisfn=~s/\?.+$//; |
unless (($thisfn =~ /^ext/) || ($thisfn =~ /\.(page|sequence)___\d+___ext/)) { |
| |
$thisfn=~s/\?.+$//; |
| |
} |
| return $thisfn; |
return $thisfn; |
| } |
} |
| |
|
|
Line 8253 sub clutter {
|
Line 9804 sub clutter {
|
| || $thisfn =~ m{^/adm/(includes|pages)} ) { |
|| $thisfn =~ m{^/adm/(includes|pages)} ) { |
| $thisfn='/res'.$thisfn; |
$thisfn='/res'.$thisfn; |
| } |
} |
| if ($thisfn !~m|/adm|) { |
if ($thisfn !~m|^/adm|) { |
| if ($thisfn =~ m|/ext/|) { |
if ($thisfn =~ m|^/ext/|) { |
| $thisfn='/adm/wrapper'.$thisfn; |
$thisfn='/adm/wrapper'.$thisfn; |
| } else { |
} else { |
| my ($ext) = ($thisfn =~ /\.(\w+)$/); |
my ($ext) = ($thisfn =~ /\.(\w+)$/); |
|
Line 8352 sub get_dns {
|
Line 9903 sub get_dns {
|
| open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); |
open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); |
| foreach my $dns (<$config>) { |
foreach my $dns (<$config>) { |
| next if ($dns !~ /^\^(\S*)/x); |
next if ($dns !~ /^\^(\S*)/x); |
| $alldns{$1} = 1; |
my $line = $1; |
| |
my ($host,$protocol) = split(/:/,$line); |
| |
if ($protocol ne 'https') { |
| |
$protocol = 'http'; |
| |
} |
| |
$alldns{$host} = $protocol; |
| } |
} |
| while (%alldns) { |
while (%alldns) { |
| my ($dns) = keys(%alldns); |
my ($dns) = keys(%alldns); |
| delete($alldns{$dns}); |
|
| my $ua=new LWP::UserAgent; |
my $ua=new LWP::UserAgent; |
| my $request=new HTTP::Request('GET',"http://$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}); |
| next if ($response->is_error()); |
next if ($response->is_error()); |
| my @content = split("\n",$response->content); |
my @content = split("\n",$response->content); |
| &Apache::lonnet::do_cache_new('dns',$url,\@content,30*24*60*60); |
&Apache::lonnet::do_cache_new('dns',$url,\@content,30*24*60*60); |
|
Line 8424 sub get_dns {
|
Line 9980 sub get_dns {
|
| } |
} |
| return $domain{$name}{$what}; |
return $domain{$name}{$what}; |
| } |
} |
| |
|
| |
sub domain_info { |
| |
&load_domain_tab() if (!$loaded); |
| |
return %domain; |
| |
} |
| |
|
| } |
} |
| |
|
| |
|
|
Line 8434 sub get_dns {
|
Line 9996 sub get_dns {
|
| my %libserv; |
my %libserv; |
| my $loaded; |
my $loaded; |
| my %name_to_host; |
my %name_to_host; |
| |
my %internetdom; |
| |
|
| sub parse_hosts_tab { |
sub parse_hosts_tab { |
| my ($file) = @_; |
my ($file) = @_; |
|
Line 8441 sub get_dns {
|
Line 10004 sub get_dns {
|
| next if ($configline =~ /^(\#|\s*$ )/x); |
next if ($configline =~ /^(\#|\s*$ )/x); |
| next if ($configline =~ /^\^/); |
next if ($configline =~ /^\^/); |
| chomp($configline); |
chomp($configline); |
| my ($id,$domain,$role,$name)=split(/:/,$configline); |
my ($id,$domain,$role,$name,$protocol,$intdom)=split(/:/,$configline); |
| $name=~s/\s//g; |
$name=~s/\s//g; |
| if ($id && $domain && $role && $name) { |
if ($id && $domain && $role && $name) { |
| $hostname{$id}=$name; |
$hostname{$id}=$name; |
| push(@{$name_to_host{$name}}, $id); |
push(@{$name_to_host{$name}}, $id); |
| $hostdom{$id}=$domain; |
$hostdom{$id}=$domain; |
| if ($role eq 'library') { $libserv{$id}=$name; } |
if ($role eq 'library') { $libserv{$id}=$name; } |
| |
if (defined($protocol)) { |
| |
if ($protocol eq 'https') { |
| |
$protocol{$id} = $protocol; |
| |
} else { |
| |
$protocol{$id} = 'http'; |
| |
} |
| |
} else { |
| |
$protocol{$id} = 'http'; |
| |
} |
| |
if (defined($intdom)) { |
| |
$internetdom{$id} = $intdom; |
| |
} |
| } |
} |
| } |
} |
| } |
} |
|
Line 8492 sub get_dns {
|
Line 10067 sub get_dns {
|
| return %name_to_host; |
return %name_to_host; |
| } |
} |
| |
|
| |
sub all_host_domain { |
| |
&load_hosts_tab() if (!$loaded); |
| |
return %hostdom; |
| |
} |
| |
|
| sub is_library { |
sub is_library { |
| &load_hosts_tab() if (!$loaded); |
&load_hosts_tab() if (!$loaded); |
| |
|
|
Line 8504 sub get_dns {
|
Line 10084 sub get_dns {
|
| return %libserv; |
return %libserv; |
| } |
} |
| |
|
| |
sub unique_library { |
| |
#2x reverse removes all hostnames that appear more than once |
| |
my %unique = reverse &all_library(); |
| |
return reverse %unique; |
| |
} |
| |
|
| sub get_servers { |
sub get_servers { |
| &load_hosts_tab() if (!$loaded); |
&load_hosts_tab() if (!$loaded); |
| |
|
|
Line 8527 sub get_dns {
|
Line 10113 sub get_dns {
|
| return %result; |
return %result; |
| } |
} |
| |
|
| |
sub get_unique_servers { |
| |
my %unique = reverse &get_servers(@_); |
| |
return reverse %unique; |
| |
} |
| |
|
| sub host_domain { |
sub host_domain { |
| &load_hosts_tab() if (!$loaded); |
&load_hosts_tab() if (!$loaded); |
| |
|
|
Line 8541 sub get_dns {
|
Line 10132 sub get_dns {
|
| my @uniq = grep(!$seen{$_}++, values(%hostdom)); |
my @uniq = grep(!$seen{$_}++, values(%hostdom)); |
| return @uniq; |
return @uniq; |
| } |
} |
| |
|
| |
sub internet_dom { |
| |
&load_hosts_tab() if (!$loaded); |
| |
|
| |
my ($lonid) = @_; |
| |
return $internetdom{$lonid}; |
| |
} |
| } |
} |
| |
|
| { |
{ |
|
Line 8633 sub get_dns {
|
Line 10231 sub get_dns {
|
| |
|
| return %iphost; |
return %iphost; |
| } |
} |
| |
|
| |
# |
| |
# Given a DNS returns the loncapa host name for that DNS |
| |
# |
| |
sub host_from_dns { |
| |
my ($dns) = @_; |
| |
my @hosts; |
| |
my $ip; |
| |
|
| |
if (exists($name_to_ip{$dns})) { |
| |
$ip = $name_to_ip{$dns}; |
| |
} |
| |
if (!$ip) { |
| |
$ip = gethostbyname($dns); # Initial translation to IP is in net order. |
| |
if (length($ip) == 4) { |
| |
$ip = &IO::Socket::inet_ntoa($ip); |
| |
} |
| |
} |
| |
if ($ip) { |
| |
@hosts = get_hosts_from_ip($ip); |
| |
return $hosts[0]; |
| |
} |
| |
return undef; |
| |
} |
| |
|
| |
sub get_internet_names { |
| |
my ($lonid) = @_; |
| |
return if ($lonid eq ''); |
| |
my ($idnref,$cached)= |
| |
&Apache::lonnet::is_cached_new('internetnames',$lonid); |
| |
if ($cached) { |
| |
return $idnref; |
| |
} |
| |
my $ip = &get_host_ip($lonid); |
| |
my @hosts = &get_hosts_from_ip($ip); |
| |
my %iphost = &get_iphost(); |
| |
my (@idns,%seen); |
| |
foreach my $id (@hosts) { |
| |
my $dom = &host_domain($id); |
| |
my $prim_id = &domain($dom,'primary'); |
| |
my $prim_ip = &get_host_ip($prim_id); |
| |
next if ($seen{$prim_ip}); |
| |
if (ref($iphost{$prim_ip}) eq 'ARRAY') { |
| |
foreach my $id (@{$iphost{$prim_ip}}) { |
| |
my $intdom = &internet_dom($id); |
| |
unless (grep(/^\Q$intdom\E$/,@idns)) { |
| |
push(@idns,$intdom); |
| |
} |
| |
} |
| |
} |
| |
$seen{$prim_ip} = 1; |
| |
} |
| |
return &Apache::lonnet::do_cache_new('internetnames',$lonid,\@idns,12*60*60); |
| |
} |
| |
|
| |
} |
| |
|
| |
sub all_loncaparevs { |
| |
return qw(1.1 1.2 1.3 2.0 2.1 2.2 2.3 2.4 2.5 2.6 2.7 2.8 2.9 2.10); |
| } |
} |
| |
|
| BEGIN { |
BEGIN { |
|
Line 8710 BEGIN {
|
Line 10367 BEGIN {
|
| close($config); |
close($config); |
| } |
} |
| |
|
| |
# ---------------------------------------------------------- Read loncaparev table |
| |
{ |
| |
if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") { |
| |
if (open(my $config,"<$perlvar{'lonTabDir'}/loncaparevs.tab")) { |
| |
while (my $configline=<$config>) { |
| |
chomp($configline); |
| |
my ($hostid,$loncaparev)=split(/:/,$configline); |
| |
$loncaparevs{$hostid}=$loncaparev; |
| |
} |
| |
close($config); |
| |
} |
| |
} |
| |
} |
| |
|
| |
# ---------------------------------------------------------- Read serverhostID table |
| |
{ |
| |
if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") { |
| |
if (open(my $config,"<$perlvar{'lonTabDir'}/serverhomeIDs.tab")) { |
| |
while (my $configline=<$config>) { |
| |
chomp($configline); |
| |
my ($name,$id)=split(/:/,$configline); |
| |
$serverhomeIDs{$name}=$id; |
| |
} |
| |
close($config); |
| |
} |
| |
} |
| |
} |
| |
|
| |
{ |
| |
my $file = $Apache::lonnet::perlvar{'lonTabDir'}.'/releaseslist.xml'; |
| |
if (-e $file) { |
| |
my $parser = HTML::LCParser->new($file); |
| |
while (my $token = $parser->get_token()) { |
| |
if ($token->[0] eq 'S') { |
| |
my $item = $token->[1]; |
| |
my $name = $token->[2]{'name'}; |
| |
my $value = $token->[2]{'value'}; |
| |
if ($item ne '' && $name ne '' && $value ne '') { |
| |
my $release = $parser->get_text(); |
| |
$release =~ s/(^\s*|\s*$ )//gx; |
| |
$needsrelease{$item.':'.$name.':'.$value} = $release; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
|
| # ------------- set up temporary directory |
# ------------- set up temporary directory |
| { |
{ |
| $tmpdir = $perlvar{'lonDaemons'}.'/tmp/'; |
$tmpdir = $perlvar{'lonDaemons'}.'/tmp/'; |
|
Line 8722 $memcache=new Cache::Memcached({'servers
|
Line 10426 $memcache=new Cache::Memcached({'servers
|
| |
|
| $processmarker='_'.time.'_'.$perlvar{'lonHostID'}; |
$processmarker='_'.time.'_'.$perlvar{'lonHostID'}; |
| $dumpcount=0; |
$dumpcount=0; |
| |
$locknum=0; |
| |
|
| &logtouch(); |
&logtouch(); |
| &logthis('<font color="yellow">INFO: Read configuration</font>'); |
&logthis('<font color="yellow">INFO: Read configuration</font>'); |
|
Line 8889 when the connection is brought back up
|
Line 10594 when the connection is brought back up
|
| =item * B<con_failed>: unable to contact remote host and unable to save message |
=item * B<con_failed>: unable to contact remote host and unable to save message |
| for later delivery |
for later delivery |
| |
|
| =item * B<error:>: an error a occured, a description of the error follows the : |
=item * B<error:>: an error a occurred, a description of the error follows the : |
| |
|
| =item * B<no_such_host>: unable to fund a host associated with the user/domain |
=item * B<no_such_host>: unable to fund a host associated with the user/domain |
| that was requested |
that was requested |
|
Line 8913 in the user's environment.db and in %env
|
Line 10618 in the user's environment.db and in %env
|
| |
|
| =item * |
=item * |
| X<delenv()> |
X<delenv()> |
| B<delenv($regexp)>: removes all items from the session |
B<delenv($delthis,$regexp)>: removes all items from the session |
| environment file that matches the regular expression in $regexp. The |
environment file that begin with $delthis. If the |
| values are also delted from the current processes %env. |
optional second arg - $regexp - is true, $delthis is treated as a |
| |
regular expression, otherwise \Q$delthis\E is used. |
| |
The values are also deleted from the current processes %env. |
| |
|
| =item * get_env_multiple($name) |
=item * get_env_multiple($name) |
| |
|
|
Line 8937 authentication scheme
|
Line 10644 authentication scheme
|
| |
|
| =item * |
=item * |
| X<authenticate()> |
X<authenticate()> |
| B<authenticate($uname,$upass,$udom)>: try to |
B<authenticate($uname,$upass,$udom,$checkdefauth,$clientcancheckhost)>: try to |
| authenticate user from domain's lib servers (first use the current |
authenticate user from domain's lib servers (first use the current |
| one). C<$upass> should be the users password. |
one). C<$upass> should be the users password. |
| |
$checkdefauth is optional (value is 1 if a check should be made to |
| |
authenticate user using default authentication method, and allow |
| |
account creation if username does not have account in the domain). |
| |
$clientcancheckhost is optional (value is 1 if checking whether the |
| |
server can host will occur on the client side in lonauth.pm). |
| |
|
| =item * |
=item * |
| X<homeserver()> |
X<homeserver()> |
|
Line 9012 and course level
|
Line 10724 and course level
|
| |
|
| =item * |
=item * |
| |
|
| plaintext($short) : return value in %prp hash (rolesplain.tab); plain text |
plaintext($short,$type,$cid,$forcedefault) : return value in %prp hash |
| explanation of a user role term |
(rolesplain.tab); plain text explanation of a user role term. |
| |
$type is Course (default) or Community. |
| |
If $forcedefault evaluates to true, text returned will be default |
| |
text for $type. Otherwise, if this is a course, the text returned |
| |
will be a custom name for the role (if defined in the course's |
| |
environment). If no custom name is defined the default is returned. |
| |
|
| =item * |
=item * |
| |
|
| get_my_roles($uname,$udom,$context,$types,$roles,$roledoms,$withsec) : |
get_my_roles($uname,$udom,$context,$types,$roles,$roledoms,$withsec) : |
|
Line 9039 provided for types, will default to retu
|
Line 10756 provided for types, will default to retu
|
| |
|
| =item * |
=item * |
| |
|
| assignrole($udom,$uname,$url,$role,$end,$start) : assign role; give a role to a |
assignrole($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll,$context) : assign role; give a role to a |
| user for the level given by URL. Optional start and end dates (leave empty |
user for the level given by URL. Optional start and end dates (leave empty |
| string or zero for "no date") |
string or zero for "no date") |
| |
|
|
Line 9056 modifyuserauth($udom,$uname,$umode,$upas
|
Line 10773 modifyuserauth($udom,$uname,$umode,$upas
|
| |
|
| =item * |
=item * |
| |
|
| modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene) : |
modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last, $gene, |
| modify user |
$forceid,$desiredhome,$email,$inststatus,$candelete) : |
| |
|
| |
will update user information (firstname,middlename,lastname,generation, |
| |
permanentemail), and if forceid is true, student/employee ID also. |
| |
A user's institutional affiliation(s) can also be updated. |
| |
User information fields will not be overwritten with empty entries |
| |
unless the field is included in the $candelete array reference. |
| |
This array is included when a single user is modified via "Manage Users", |
| |
or when Autoupdate.pl is run by cron in a domain. |
| |
|
| =item * |
=item * |
| |
|
| modifystudent |
modifystudent |
| |
|
| modify a students enrollment and identification information. |
modify a student's enrollment and identification information. |
| The course id is resolved based on the current users environment. |
The course id is resolved based on the current users environment. |
| This means the envoking user must be a course coordinator or otherwise |
This means the envoking user must be a course coordinator or otherwise |
| associated with a course. |
associated with a course. |
|
Line 9075 Inputs:
|
Line 10800 Inputs:
|
| |
|
| =over 4 |
=over 4 |
| |
|
| =item B<$udom> Students loncapa domain |
=item B<$udom> Student's loncapa domain |
| |
|
| =item B<$uname> Students loncapa login name |
=item B<$uname> Student's loncapa login name |
| |
|
| =item B<$uid> Students id/student number |
=item B<$uid> Student/Employee ID |
| |
|
| =item B<$umode> Students authentication mode |
=item B<$umode> Student's authentication mode |
| |
|
| =item B<$upass> Students password |
=item B<$upass> Student's password |
| |
|
| =item B<$first> Students first name |
=item B<$first> Student's first name |
| |
|
| =item B<$middle> Students middle name |
=item B<$middle> Student's middle name |
| |
|
| =item B<$last> Students last name |
=item B<$last> Student's last name |
| |
|
| =item B<$gene> Students generation |
=item B<$gene> Student's generation |
| |
|
| =item B<$usec> Students section in course |
=item B<$usec> Student's section in course |
| |
|
| =item B<$end> Unix time of the roles expiration |
=item B<$end> Unix time of the roles expiration |
| |
|
|
Line 9103 Inputs:
|
Line 10828 Inputs:
|
| |
|
| =item B<$desiredhome> server to use as home server for student |
=item B<$desiredhome> server to use as home server for student |
| |
|
| |
=item B<$email> Student's permanent e-mail address |
| |
|
| |
=item B<$type> Type of enrollment (auto or manual) |
| |
|
| |
=item B<$locktype> boolean - enrollment type locked to prevent Autoenroll.pl changing manual to auto |
| |
|
| |
=item B<$cid> courseID - needed if a course role is assigned by a user whose current role is DC |
| |
|
| |
=item B<$selfenroll> boolean - 1 if user role change occurred via self-enrollment |
| |
|
| |
=item B<$context> role change context (shown in User Management Logs display in a course) |
| |
|
| |
=item B<$inststatus> institutional status of user - : separated string of escaped status types |
| |
|
| =back |
=back |
| |
|
| =item * |
=item * |
|
Line 9136 Inputs:
|
Line 10875 Inputs:
|
| |
|
| =item $start |
=item $start |
| |
|
| |
=item $type |
| |
|
| |
=item $locktype |
| |
|
| |
=item $cid |
| |
|
| |
=item $selfenroll |
| |
|
| |
=item $context |
| |
|
| =back |
=back |
| |
|
| |
|
|
Line 9194 database) for a course
|
Line 10943 database) for a course
|
| |
|
| =item * |
=item * |
| |
|
| createcourse($udom,$description,$url) : make/modify course |
createcourse($udom,$description,$url,$course_server,$nonstandard,$inst_code,$course_owner,$crstype,$cnum) : make course |
| |
|
| |
=item * |
| |
|
| |
generate_coursenum($udom,$crstype) : get a unique (unused) course number in domain $udom for course type $crstype (Course or Community). |
| |
|
| =back |
=back |
| |
|
|
Line 9444 Returns:
|
Line 11197 Returns:
|
| 'key_exists: <key>' -> failed to anything out of $storehash, as at |
'key_exists: <key>' -> failed to anything out of $storehash, as at |
| least <key> already existed in the db (other |
least <key> already existed in the db (other |
| requested keys may also already exist) |
requested keys may also already exist) |
| 'error: <msg>' -> unable to tie the DB or other erorr occured |
'error: <msg>' -> unable to tie the DB or other error occurred |
| 'con_lost' -> unable to contact request server |
'con_lost' -> unable to contact request server |
| 'refused' -> action was not allowed by remote machine |
'refused' -> action was not allowed by remote machine |
| |
|
|
Line 9498 dirlist($uri) : return directory list ba
|
Line 11251 dirlist($uri) : return directory list ba
|
| |
|
| spareserver() : find server with least workload from spare.tab |
spareserver() : find server with least workload from spare.tab |
| |
|
| |
|
| |
=item * |
| |
|
| |
host_from_dns($dns) : Returns the loncapa hostname corresponding to a DNS name or undef |
| |
if there is no corresponding loncapa host. |
| |
|
| =back |
=back |
| |
|
| |
|
| =head2 Apache Request |
=head2 Apache Request |
| |
|
| =over 4 |
=over 4 |
![[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