|
version 1.948, 2008/03/10 23:26:28
|
version 1.996, 2009/05/06 12:13:26
|
|
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); |
| |
|
| 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 56 use LONCAPA::Configuration;
|
Line 98 use LONCAPA::Configuration;
|
| my $readit; |
my $readit; |
| my $max_connection_retries = 10; # Or some such value. |
my $max_connection_retries = 10; # Or some such value. |
| |
|
| |
my $upload_photo_form = 0; #Variable to check when user upload a photo 0=not 1=true |
| |
|
| require Exporter; |
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 149 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 181 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) = @_; |
| |
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 = 24*3600; |
| |
my ($loncaparev,$cached)=&is_cached_new('serverloncaparev',$lonhost); |
| |
if (defined($cached)) { |
| |
return $loncaparev; |
| |
} else { |
| |
my $loncaparev = &reply('serverloncaparev',$lonhost); |
| |
return &do_cache_new('serverloncaparev',$lonhost,$loncaparev,$cachetime); |
| |
} |
| |
} |
| |
} |
| |
|
| # -------------------------------------------------- Non-critical communication |
# -------------------------------------------------- Non-critical communication |
| sub subreply { |
sub subreply { |
|
Line 448 sub timed_flock {
|
Line 514 sub timed_flock {
|
| # ---------------------------------------------------------- Append Environment |
# ---------------------------------------------------------- Append Environment |
| |
|
| sub appenv { |
sub appenv { |
| my %newenv=@_; |
my ($newenv,$roles) = @_; |
| foreach my $key (keys(%newenv)) { |
if (ref($newenv) eq 'HASH') { |
| if (($newenv{$key}=~/^user\.role/) || ($newenv{$key}=~/^user\.priv/)) { |
foreach my $key (keys(%{$newenv})) { |
| &logthis("<font color=\"blue\">WARNING: ". |
my $refused = 0; |
| "Attempt to modify environment ".$key." to ".$newenv{$key} |
if (($key =~ /^user\.role/) || ($key =~ /^user\.priv/)) { |
| .'</font>'); |
$refused = 1; |
| delete($newenv{$key}); |
if (ref($roles) eq 'ARRAY') { |
| } else { |
my ($type,$role) = ($key =~ /^user\.(role|priv)\.([^.]+)\./); |
| $env{$key}=$newenv{$key}; |
if (grep(/^\Q$role\E$/,@{$roles})) { |
| |
$refused = 0; |
| |
} |
| |
} |
| |
} |
| |
if ($refused) { |
| |
&logthis("<font color=\"blue\">WARNING: ". |
| |
"Attempt to modify environment ".$key." to ".$newenv->{$key} |
| |
.'</font>'); |
| |
delete($newenv->{$key}); |
| |
} else { |
| |
$env{$key}=$newenv->{$key}; |
| |
} |
| |
} |
| |
my $opened = open(my $env_file,'+<',$env{'user.environment'}); |
| |
if ($opened |
| |
&& &timed_flock($env_file,LOCK_EX) |
| |
&& |
| |
tie(my %disk_env,'GDBM_File',$env{'user.environment'}, |
| |
(&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { |
| |
while (my ($key,$value) = each(%{$newenv})) { |
| |
$disk_env{$key} = $value; |
| |
} |
| |
untie(%disk_env); |
| } |
} |
| } |
|
| my $opened = open(my $env_file,'+<',$env{'user.environment'}); |
|
| if ($opened |
|
| && &timed_flock($env_file,LOCK_EX) |
|
| && |
|
| tie(my %disk_env,'GDBM_File',$env{'user.environment'}, |
|
| (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { |
|
| while (my ($key,$value) = each(%newenv)) { |
|
| $disk_env{$key} = $value; |
|
| } |
|
| untie(%disk_env); |
|
| } |
} |
| return 'ok'; |
return 'ok'; |
| } |
} |
| # ----------------------------------------------------- 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 488 sub delenv {
|
Line 566 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 512 sub get_env_multiple {
|
Line 597 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 584 sub spareserver {
|
Line 714 sub spareserver {
|
| } |
} |
| |
|
| 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}; |
| |
} |
| |
$spare_server = $protocol.'://'.&hostname($spare_server); |
| } |
} |
| return $spare_server; |
return $spare_server; |
| } |
} |
|
Line 693 sub queryauthenticate {
|
Line 827 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)=@_; |
my ($uname,$upass,$udom,$checkdefauth)=@_; |
| $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); |
| |
my $newhome; |
| if ((!$uhome) || ($uhome eq 'no_host')) { |
if ((!$uhome) || ($uhome eq 'no_host')) { |
| # Maybe the machine was offline and only re-appeared again recently? |
# Maybe the machine was offline and only re-appeared again recently? |
| &reconlonc(); |
&reconlonc(); |
| # One more |
# One more |
| my $uhome=&homeserver($uname,$udom,1); |
$uhome=&homeserver($uname,$udom,1); |
| |
if (($uhome eq 'no_host') && $checkdefauth) { |
| |
if (defined(&domain($udom,'primary'))) { |
| |
$newhome=&domain($udom,'primary'); |
| |
} |
| |
if ($newhome ne '') { |
| |
$uhome = $newhome; |
| |
} |
| |
} |
| if ((!$uhome) || ($uhome eq 'no_host')) { |
if ((!$uhome) || ($uhome eq 'no_host')) { |
| &logthis("User $uname at $udom is unknown in authenticate"); |
&logthis("User $uname at $udom is unknown in authenticate"); |
| } |
return 'no_host'; |
| return 'no_host'; |
} |
| } |
} |
| my $answer=reply("encrypt:auth:$udom:$uname:$upass",$uhome); |
my $answer=reply("encrypt:auth:$udom:$uname:$upass:$checkdefauth",$uhome); |
| if ($answer eq 'authorized') { |
if ($answer eq 'authorized') { |
| &logthis("User $uname at $udom authorized by $uhome"); |
if ($newhome) { |
| return $uhome; |
&logthis("User $uname at $udom authorized by $uhome, but needs account"); |
| |
return 'no_account_on_host'; |
| |
} else { |
| |
&logthis("User $uname at $udom authorized by $uhome"); |
| |
return $uhome; |
| |
} |
| } |
} |
| if ($answer eq 'non_authorized') { |
if ($answer eq 'non_authorized') { |
| &logthis("User $uname at $udom rejected by $uhome"); |
&logthis("User $uname at $udom rejected by $uhome"); |
|
Line 882 sub put_dom {
|
Line 1030 sub put_dom {
|
| 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 1122 sub inst_userrules {
|
Line 1281 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 1136 sub get_domain_defaults {
|
Line 1294 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'],$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') { |
| |
$domdefaults{$item} = $domconfig{'requestcourses'}{$item}; |
| |
} |
| |
} |
| |
if (ref($domconfig{'inststatus'}) eq 'HASH') { |
| |
foreach my $item ('inststatustypes','inststatusorder') { |
| |
$domdefaults{$item} = $domconfig{'inststatus'}{$item}; |
| |
} |
| |
} |
| &Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults, |
&Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults, |
| $cachetime); |
$cachetime); |
| return %domdefaults; |
return %domdefaults; |
|
Line 1183 sub assign_access_key {
|
Line 1367 sub assign_access_key {
|
| # key now belongs to user |
# key now belongs to user |
| my $envkey='key.'.$cdom.'_'.$cnum; |
my $envkey='key.'.$cdom.'_'.$cnum; |
| if (&put('environment',{$envkey => $ckey}) eq 'ok') { |
if (&put('environment',{$envkey => $ckey}) eq 'ok') { |
| &appenv('environment.'.$envkey => $ckey); |
&appenv({'environment.'.$envkey => $ckey}); |
| return 'ok'; |
return 'ok'; |
| } else { |
} else { |
| return |
return |
|
Line 1470 sub purge_remembered {
|
Line 1654 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 @answer=split(/\&/, |
| &reply('get:'.$udom.':'.$unam.':environment:'.join('&',@what), |
&reply('get:'.$udom.':'.$unam.':environment:'.$items, |
| &homeserver($unam,$udom))); |
&homeserver($unam,$udom))); |
| my $i; |
my $i; |
| for ($i=0;$i<=$#what;$i++) { |
for ($i=0;$i<=$#what;$i++) { |
|
Line 1667 sub ssi_body {
|
Line 1856 sub ssi_body {
|
| if (! exists($form{'LONCAPA_INTERNAL_no_discussion'})) { |
if (! exists($form{'LONCAPA_INTERNAL_no_discussion'})) { |
| $form{'LONCAPA_INTERNAL_no_discussion'}='true'; |
$form{'LONCAPA_INTERNAL_no_discussion'}='true'; |
| } |
} |
| my $output=($filelink=~/^http\:/?&externalssi($filelink): |
my $output=''; |
| &ssi($filelink,%form)); |
my $response; |
| |
if ($filelink=~/^https?\:/) { |
| |
($output,$response)=&externalssi($filelink); |
| |
} else { |
| |
($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; |
| $output=~s/^.*?\<body[^\>]*\>//si; |
$output=~s/^.*?\<body[^\>]*\>//si; |
| $output=~s/\<\/body\s*\>.*?$//si; |
$output=~s/\<\/body\s*\>.*?$//si; |
| return $output; |
if (wantarray) { |
| |
return ($output, $response); |
| |
} else { |
| |
return $output; |
| |
} |
| } |
} |
| |
|
| # --------------------------------------------------------- Server Side Include |
# --------------------------------------------------------- Server Side Include |
|
Line 1693 sub absolute_url {
|
Line 1891 sub absolute_url {
|
| # form Hash that describes how the rendering should be done |
# form Hash that describes how the rendering should be done |
| # and other things. |
# and other things. |
| # Returns: |
# Returns: |
| # Scalar context: The content of the reply. |
# Scalar context: The content of the response. |
| # Array context: 2 element list of the content and the full response variable. |
# Array context: 2 element list of the content and the full response object. |
| # |
# |
| # Returns: |
|
| # The content of the response. |
|
| sub ssi { |
sub ssi { |
| |
|
| my ($fn,%form)=@_; |
my ($fn,%form)=@_; |
| my $count = scalar(@_); |
|
| |
|
| |
|
| my $ua=new LWP::UserAgent; |
my $ua=new LWP::UserAgent; |
| |
|
| my $request; |
my $request; |
| |
|
| $form{'no_update_last_known'}=1; |
$form{'no_update_last_known'}=1; |
|
Line 1719 sub ssi {
|
Line 1911 sub ssi {
|
| |
|
| $request->header(Cookie => $ENV{'HTTP_COOKIE'}); |
$request->header(Cookie => $ENV{'HTTP_COOKIE'}); |
| my $response=$ua->request($request); |
my $response=$ua->request($request); |
| my $status = $response->code; |
|
| |
|
| if (wantarray) { |
if (wantarray) { |
| return ($response->content, $response); |
return ($response->content, $response); |
|
Line 1733 sub externalssi {
|
Line 1924 sub externalssi {
|
| my $ua=new LWP::UserAgent; |
my $ua=new LWP::UserAgent; |
| my $request=new HTTP::Request('GET',$url); |
my $request=new HTTP::Request('GET',$url); |
| my $response=$ua->request($request); |
my $response=$ua->request($request); |
| return $response->content; |
if (wantarray) { |
| |
return ($response->content, $response); |
| |
} else { |
| |
return $response->content; |
| |
} |
| } |
} |
| |
|
| # -------------------------------- Allow a /uploaded/ URI to be vouched for |
# -------------------------------- Allow a /uploaded/ URI to be vouched for |
|
Line 1746 sub allowuploaded {
|
Line 1941 sub allowuploaded {
|
| my %httpref=(); |
my %httpref=(); |
| my $httpurl=&hreflocation('',$url); |
my $httpurl=&hreflocation('',$url); |
| $httpref{'httpref.'.$httpurl}=$srcurl; |
$httpref{'httpref.'.$httpurl}=$srcurl; |
| &Apache::lonnet::appenv(%httpref); |
&Apache::lonnet::appenv(\%httpref); |
| } |
} |
| |
|
| # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course |
# --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course |
|
Line 1807 sub process_coursefile {
|
Line 2002 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 $parse_result = &extract_embedded_items($filepath.'/'.$fname,$allfiles,$codebase); |
| unless ($parse_result eq 'ok') { |
unless ($parse_result eq 'ok') { |
| &logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result); |
&logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result); |
| } |
} |
|
Line 1886 sub clean_filename {
|
Line 2081 sub clean_filename {
|
| $fname=~s/\.(\d+)(?=\.)/_$1/g; |
$fname=~s/\.(\d+)(?=\.)/_$1/g; |
| return $fname; |
return $fname; |
| } |
} |
| |
#This Function check if a Image max 400px width and height 500px. If not then scale the image down |
| |
sub resizeImage { |
| |
my($img_url) = @_; |
| |
my $ima = Image::Magick->new; |
| |
$ima->Read($img_url); |
| |
if($ima->Get('width') > 400) |
| |
{ |
| |
my $factor = $ima->Get('width')/400; |
| |
$ima->Scale( width=>400, height=>$ima->Get('height')/$factor ); |
| |
} |
| |
if($ima->Get('height') > 500) |
| |
{ |
| |
my $factor = $ima->Get('height')/500; |
| |
$ima->Scale( width=>$ima->Get('width')/$factor, height=>500); |
| |
} |
| |
|
| |
$ima->Write($img_url); |
| |
} |
| |
|
| |
#Wrapper function for userphotoupload |
| |
sub userphotoupload |
| |
{ |
| |
my($formname,$subdir) = @_; |
| |
$upload_photo_form = 1; |
| |
return &userfileupload($formname,undef,$subdir); |
| |
} |
| |
|
| # --------------- 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 1945 sub userfileupload {
|
Line 2166 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'}; |
|
Line 1986 sub finishuserfileupload {
|
Line 2210 sub finishuserfileupload {
|
| $thumbwidth,$thumbheight) = @_; |
$thumbwidth,$thumbheight) = @_; |
| 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 2000 sub finishuserfileupload {
|
Line 2225 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 2013 sub finishuserfileupload {
|
Line 2239 sub finishuserfileupload {
|
| return '/adm/notfound.html'; |
return '/adm/notfound.html'; |
| } |
} |
| close(FH); |
close(FH); |
| |
if($upload_photo_form==1) |
| |
{ |
| |
resizeImage($filepath.'/'.$file); |
| |
$upload_photo_form = 0; |
| |
} |
| } |
} |
| if ($parser eq 'parse') { |
if ($parser eq 'parse') { |
| my $parse_result = &extract_embedded_items($filepath,$file,$allfiles, |
my $parse_result = &extract_embedded_items($filepath.'/'.$file,$allfiles, |
| $codebase); |
$codebase); |
| unless ($parse_result eq 'ok') { |
unless ($parse_result eq 'ok') { |
| &logthis('Failed to parse '.$filepath.$file. |
&logthis('Failed to parse '.$filepath.$file. |
|
Line 2034 sub finishuserfileupload {
|
Line 2265 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 2055 sub finishuserfileupload {
|
Line 2286 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 2070 sub extract_embedded_items {
|
Line 2301 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 2166 sub add_filetype {
|
Line 2397 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 2383 sub courseacclog {
|
Line 2614 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 2448 sub userrolelog {
|
Line 2684 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')) { |
| |
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 2482 sub get_course_adv_roles {
|
Line 2752 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 2653 sub courseidput {
|
Line 2923 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)=@_; |
| my $as_hash = 1; |
my $as_hash = 1; |
| my %returnhash; |
my %returnhash; |
| if (!$domfilter) { $domfilter=''; } |
if (!$domfilter) { $domfilter=''; } |
|
Line 2671 sub courseiddump {
|
Line 2941 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,$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 3408 sub coursedescription {
|
Line 3679 sub coursedescription {
|
| } |
} |
| } |
} |
| if (!$args->{'one_time'}) { |
if (!$args->{'one_time'}) { |
| &appenv(%envhash); |
&appenv(\%envhash); |
| } |
} |
| return %returnhash; |
return %returnhash; |
| } |
} |
|
Line 3447 sub privileged {
|
Line 3718 sub privileged {
|
| |
|
| sub rolesinit { |
sub rolesinit { |
| my ($domain,$username,$authhost)=@_; |
my ($domain,$username,$authhost)=@_; |
| |
my %userroles; |
| my $rolesdump=reply("dump:$domain:$username:roles",$authhost); |
my $rolesdump=reply("dump:$domain:$username:roles",$authhost); |
| if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; } |
if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return \%userroles; } |
| my %allroles=(); |
my %allroles=(); |
| my %allgroups=(); |
my %allgroups=(); |
| my $now=time; |
my $now=time; |
| my %userroles = ('user.login.time' => $now); |
%userroles = ('user.login.time' => $now); |
| my $group_privs; |
my $group_privs; |
| |
|
| if ($rolesdump ne '') { |
if ($rolesdump ne '') { |
|
Line 3614 sub set_userprivs {
|
Line 3886 sub set_userprivs {
|
| return ($author,$adv); |
return ($author,$adv); |
| } |
} |
| |
|
| |
sub role_status { |
| |
my ($rolekey,$then,$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) { $$tstatus='will'; } |
| |
} |
| |
if ($$tend) { |
| |
if ($$tend<$then) { |
| |
$$tstatus='expired'; |
| |
} elsif ($$tend<$now) { |
| |
$$tstatus='will_not'; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
|
| |
sub check_adhoc_privs { |
| |
my ($cdom,$cnum,$then,$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,$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 3649 sub del {
|
Line 3982 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); |
| } |
} |
| |
|
|
Line 3957 sub tmpget {
|
Line 4290 sub tmpget {
|
| my %returnhash; |
my %returnhash; |
| foreach my $item (split(/\&/,$rep)) { |
foreach my $item (split(/\&/,$rep)) { |
| my ($key,$value)=split(/=/,$item); |
my ($key,$value)=split(/=/,$item); |
| |
next if ($key =~ /^error: 2 /); |
| $returnhash{&unescape($key)}=&thaw_unescape($value); |
$returnhash{&unescape($key)}=&thaw_unescape($value); |
| } |
} |
| return %returnhash; |
return %returnhash; |
|
Line 4212 sub is_portfolio_file {
|
Line 4546 sub is_portfolio_file {
|
| return; |
return; |
| } |
} |
| |
|
| |
sub usertools_access { |
| |
my ($uname,$udom,$tool,$action,$context) = @_; |
| |
my ($access,%tools); |
| |
if ($context eq '') { |
| |
$context = 'tools'; |
| |
} |
| |
if ($context eq 'requestcourses') { |
| |
%tools = ( |
| |
official => 1, |
| |
unofficial => 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 { |
| |
my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool); |
| |
$toolstatus = $userenv{$context.'.'.$tool}; |
| |
$inststatus = $userenv{'inststatus'}; |
| |
} |
| |
|
| |
if ($toolstatus ne '') { |
| |
if ($toolstatus) { |
| |
$access = 1; |
| |
} else { |
| |
$access = 0; |
| |
} |
| |
return $access; |
| |
} |
| |
|
| |
my $is_adv = &is_advanced_user($udom,$uname); |
| |
my %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_advanced_user { |
| |
my ($udom,$uname) = @_; |
| |
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; |
| |
} |
| |
|
| # ---------------------------------------------- Custom access rule evaluation |
# ---------------------------------------------- Custom access rule evaluation |
| |
|
|
Line 4424 sub allowed {
|
Line 4900 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 4777 sub log_query {
|
Line 5252 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 5203 sub toggle_coursegroup_status {
|
Line 5681 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 5296 sub devalidate_getgroups_cache {
|
Line 5774 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 =~ /^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'})) { |
if (defined($cid) && ($env{'course.'.$cid.'.'.$short.'.plaintext'} ne '')) { |
| return &Apache::lonlocal::mt($env{'course.'.$cid.'.'.$short. |
unless ($forcedefault) { |
| '.plaintext'}); |
my $roletext = $env{'course.'.$cid.'.'.$short.'.plaintext'}; |
| |
&Apache::lonlocal::mt_escape(\$roletext); |
| |
return &Apache::lonlocal::mt($roletext); |
| |
} |
| } |
} |
| my %rolenames = ( |
my %rolenames = ( |
| Course => 'std', |
Course => 'std', |
|
Line 5323 sub plaintext {
|
Line 5804 sub plaintext {
|
| # ----------------------------------------------------------------- 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; |
|
Line 5382 sub assignrole {
|
Line 5864 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 5392 sub assignrole {
|
Line 5875 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 5400 sub assignrole {
|
Line 5884 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); |
| } |
} |
| } |
} |
| return $answer; |
return $answer; |
|
Line 5440 sub modifyuser {
|
Line 5925 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)=@_; |
| $udom= &LONCAPA::clean_domain($udom); |
$udom= &LONCAPA::clean_domain($udom); |
| $uname=&LONCAPA::clean_username($uname); |
$uname=&LONCAPA::clean_username($uname); |
| &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. |
&logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. |
|
Line 5501 sub modifyuser {
|
Line 5986 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; |
| if ($tmp[0] =~ m/^error:.*/) { |
if ($tmp[0] =~ m/^error:.*/) { |
|
Line 5519 sub modifyuser {
|
Line 6004 sub modifyuser {
|
| 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 $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; } |
| 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.', '. |
my $logmsg = 'Success modifying user '.$udom.', '.$uname.', '.$uid.', '. |
| $umode.', '.$first.', '.$middle.', '. |
$umode.', '.$first.', '.$middle.', '. |
| $last.', '.$gene.' by '. |
$last.', '.$gene.', '.$email.', '.$inststatus; |
| $env{'user.name'}.' at '.$env{'user.domain'}); |
if ($env{'user.name'} ne '' && $env{'user.domain'}) { |
| |
$logmsg .= ' by '.$env{'user.name'}.' at '.$env{'user.domain'}; |
| |
} else { |
| |
$logmsg .= ' during self creation'; |
| |
} |
| |
&logthis($logmsg); |
| return 'ok'; |
return 'ok'; |
| } |
} |
| |
|
|
Line 5539 sub modifyuser {
|
Line 6042 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 5548 sub modifystudent {
|
Line 6052 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 5617 sub modify_student_enrollment {
|
Line 6121 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 5746 sub is_course {
|
Line 6250 sub is_course {
|
| # ---------------------------------------------------------- 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 |
| sub diskusage { |
sub diskusage { |
| my ($udom,$uname,$directoryRoot)=@_; |
my ($udom,$uname,$directorypath,$getpropath)=@_; |
| $directoryRoot =~ s/\/$//; |
$directorypath =~ s/\/$//; |
| my $listing=&reply('du:'.$directoryRoot,homeserver($uname,$udom)); |
my $listing=&reply('du2:'.&escape($directorypath).':' |
| |
.&escape($getpropath).':'.&escape($uname).':' |
| |
.&escape($udom),homeserver($uname,$udom)); |
| |
if ($listing eq 'unknown_cmd') { |
| |
if ($getpropath) { |
| |
$directorypath = &propath($udom,$uname).'/'.$directorypath; |
| |
} |
| |
$listing = &reply('du:'.$directorypath,homeserver($uname,$udom)); |
| |
} |
| return $listing; |
return $listing; |
| } |
} |
| |
|
|
Line 6013 sub modify_access_controls {
|
Line 6525 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 6189 sub unmark_as_readonly {
|
Line 6699 sub unmark_as_readonly {
|
| # ------------------------------------------------------------ Directory lister |
# ------------------------------------------------------------ Directory lister |
| |
|
| sub dirlist { |
sub dirlist { |
| my ($uri,$userdomain,$username,$alternateDirectoryRoot)=@_; |
my ($uri,$userdomain,$username,$getpropath,$getuserdir,$alternateRoot)=@_; |
| |
|
| $uri=~s/^\///; |
$uri=~s/^\///; |
| $uri=~s/\/$//; |
$uri=~s/\/$//; |
| my ($udom, $uname); |
my ($udom, $uname); |
| (undef,$udom,$uname)=split(/\//,$uri); |
if ($getuserdir) { |
| if(defined($userdomain)) { |
|
| $udom = $userdomain; |
$udom = $userdomain; |
| } |
|
| if(defined($username)) { |
|
| $uname = $username; |
$uname = $username; |
| |
} else { |
| |
(undef,$udom,$uname)=split(/\//,$uri); |
| |
if(defined($userdomain)) { |
| |
$udom = $userdomain; |
| |
} |
| |
if(defined($username)) { |
| |
$uname = $username; |
| |
} |
| } |
} |
| |
my ($dirRoot,$listing,@listing_results); |
| |
|
| my $dirRoot = $perlvar{'lonDocRoot'}; |
$dirRoot = $perlvar{'lonDocRoot'}; |
| if(defined($alternateDirectoryRoot)) { |
if (defined($getpropath)) { |
| $dirRoot = $alternateDirectoryRoot; |
$dirRoot = &propath($udom,$uname); |
| $dirRoot =~ s/\/$//; |
$dirRoot =~ s/\/$//; |
| |
} elsif (defined($getuserdir)) { |
| |
my $subdir=$uname.'__'; |
| |
$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; |
| |
$dirRoot = $Apache::lonnet::perlvar{'lonUsersDir'} |
| |
."/$udom/$subdir/$uname"; |
| |
} elsif (defined($alternateRoot)) { |
| |
$dirRoot = $alternateRoot; |
| } |
} |
| |
|
| if($udom) { |
if($udom) { |
| if($uname) { |
if($uname) { |
| my $listing = &reply('ls2:'.$dirRoot.'/'.$uri, |
$listing = &reply('ls3:'.&escape('/'.$uri).':'.$getpropath.':' |
| &homeserver($uname,$udom)); |
.$getuserdir.':'.&escape($dirRoot) |
| my @listing_results; |
.':'.&escape($uname).':'.&escape($udom), |
| |
&homeserver($uname,$udom)); |
| |
if ($listing eq 'unknown_cmd') { |
| |
$listing = &reply('ls2:'.$dirRoot.'/'.$uri, |
| |
&homeserver($uname,$udom)); |
| |
} else { |
| |
@listing_results = map { &unescape($_); } split(/:/,$listing); |
| |
} |
| if ($listing eq 'unknown_cmd') { |
if ($listing eq 'unknown_cmd') { |
| $listing = &reply('ls:'.$dirRoot.'/'.$uri, |
$listing = &reply('ls:'.$dirRoot.'/'.$uri, |
| &homeserver($uname,$udom)); |
&homeserver($uname,$udom)); |
|
Line 6221 sub dirlist {
|
Line 6750 sub dirlist {
|
| @listing_results = map { &unescape($_); } split(/:/,$listing); |
@listing_results = map { &unescape($_); } split(/:/,$listing); |
| } |
} |
| return @listing_results; |
return @listing_results; |
| } elsif(!defined($alternateDirectoryRoot)) { |
} elsif(!$alternateRoot) { |
| my %allusers; |
my %allusers; |
| my %servers = &get_servers($udom,'library'); |
my %servers = &get_servers($udom,'library'); |
| foreach my $tryserver (keys(%servers)) { |
foreach my $tryserver (keys(%servers)) { |
| my $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'. |
$listing = &reply('ls3:'.&escape("/res/$udom").':::::'. |
| $udom, $tryserver); |
&escape($udom),$tryserver); |
| my @listing_results; |
if ($listing eq 'unknown_cmd') { |
| |
$listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'. |
| |
$udom, $tryserver); |
| |
} else { |
| |
@listing_results = map { &unescape($_); } split(/:/,$listing); |
| |
} |
| if ($listing eq 'unknown_cmd') { |
if ($listing eq 'unknown_cmd') { |
| $listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'. |
$listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'. |
| $udom, $tryserver); |
$udom, $tryserver); |
|
Line 6254 sub dirlist {
|
Line 6788 sub dirlist {
|
| } else { |
} else { |
| return ('missing user name'); |
return ('missing user name'); |
| } |
} |
| } elsif(!defined($alternateDirectoryRoot)) { |
} elsif(!defined($getpropath)) { |
| my @all_domains = sort(&all_domains()); |
my @all_domains = sort(&all_domains()); |
| foreach my $domain (@all_domains) { |
foreach my $domain (@all_domains) { |
| $domain = $perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain'; |
$domain = $perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain'; |
| } |
} |
| return @all_domains; |
return @all_domains; |
| } else { |
} else { |
| return ('missing domain'); |
return ('missing domain'); |
| } |
} |
| } |
} |
|
Line 6270 sub dirlist {
|
Line 6804 sub dirlist {
|
| # when it was last modified. It will also return an error of -1 |
# when it was last modified. It will also return an error of -1 |
| # if an error occurs |
# if an error occurs |
| |
|
| ## |
|
| ## FIXME: This subroutine assumes its caller knows something about the |
|
| ## directory structure of the home server for the student ($root). |
|
| ## Not a good assumption to make. Since this is for looking up files |
|
| ## in user directories, the full path should be constructed by lond, not |
|
| ## whatever machine we request data from. |
|
| ## |
|
| sub GetFileTimestamp { |
sub GetFileTimestamp { |
| my ($studentDomain,$studentName,$filename,$root)=@_; |
my ($studentDomain,$studentName,$filename,$getuserdir)=@_; |
| $studentDomain = &LONCAPA::clean_domain($studentDomain); |
$studentDomain = &LONCAPA::clean_domain($studentDomain); |
| $studentName = &LONCAPA::clean_username($studentName); |
$studentName = &LONCAPA::clean_username($studentName); |
| my $subdir=$studentName.'__'; |
my ($fileStat) = |
| $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; |
&Apache::lonnet::dirlist($filename,$studentDomain,$studentName, |
| my $proname="$studentDomain/$subdir/$studentName"; |
undef,$getuserdir); |
| $proname .= '/'.$filename; |
|
| my ($fileStat) = &Apache::lonnet::dirlist($proname, $studentDomain, |
|
| $studentName, $root); |
|
| my @stats = split('&', $fileStat); |
my @stats = split('&', $fileStat); |
| if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') { |
if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') { |
| # @stats contains first the filename, then the stat output |
# @stats contains first the filename, then the stat output |
|
Line 6300 sub stat_file {
|
Line 6824 sub stat_file {
|
| my ($uri) = @_; |
my ($uri) = @_; |
| $uri = &clutter_with_no_wrapper($uri); |
$uri = &clutter_with_no_wrapper($uri); |
| |
|
| my ($udom,$uname,$file,$dir); |
my ($udom,$uname,$file); |
| if ($uri =~ m-^/(uploaded|editupload)/-) { |
if ($uri =~ m-^/(uploaded|editupload)/-) { |
| ($udom,$uname,$file) = |
($udom,$uname,$file) = |
| ($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_name)/?(.*)-); |
($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_name)/?(.*)-); |
| $file = 'userfiles/'.$file; |
$file = 'userfiles/'.$file; |
| $dir = &propath($udom,$uname); |
|
| } |
} |
| if ($uri =~ m-^/res/-) { |
if ($uri =~ m-^/res/-) { |
| ($udom,$uname) = |
($udom,$uname) = |
|
Line 6317 sub stat_file {
|
Line 6840 sub stat_file {
|
| # unable to handle the uri |
# unable to handle the uri |
| return (); |
return (); |
| } |
} |
| |
my $getpropath; |
| my ($result) = &dirlist($file,$udom,$uname,$dir); |
if ($file =~ /^userfiles\//) { |
| |
$getpropath = 1; |
| |
} |
| |
my ($result) = &dirlist($file,$udom,$uname,$getpropath); |
| my @stats = split('&', $result); |
my @stats = split('&', $result); |
| |
|
| if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') { |
if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') { |
|
Line 6351 sub directcondval {
|
Line 6877 sub directcondval {
|
| untie(%bighash); |
untie(%bighash); |
| } |
} |
| my $value = &docondval($sub_condition); |
my $value = &docondval($sub_condition); |
| &appenv('user.state.'.$env{'request.course.id'}.".$number" => $value); |
&appenv({'user.state.'.$env{'request.course.id'}.".$number" => $value}); |
| return $value; |
return $value; |
| } |
} |
| if ($env{'user.state.'.$env{'request.course.id'}}) { |
if ($env{'user.state.'.$env{'request.course.id'}}) { |
|
Line 6537 sub EXT_cache_status {
|
Line 7063 sub EXT_cache_status {
|
| sub EXT_cache_set { |
sub EXT_cache_set { |
| my ($target_domain,$target_user) = @_; |
my ($target_domain,$target_user) = @_; |
| my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain; |
my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain; |
| #&appenv($cachename => time); |
#&appenv({$cachename => time}); |
| } |
} |
| |
|
| # --------------------------------------------------------- Value of a Variable |
# --------------------------------------------------------- Value of a Variable |
|
Line 7439 sub symbread {
|
Line 7965 sub symbread {
|
| if ($syval) { |
if ($syval) { |
| #unless ($syval=~/\_\d+$/) { |
#unless ($syval=~/\_\d+$/) { |
| #unless ($env{'form.request.prefix'}=~/\.(\d+)\_$/) { |
#unless ($env{'form.request.prefix'}=~/\.(\d+)\_$/) { |
| #&appenv('request.ambiguous' => $thisfn); |
#&appenv({'request.ambiguous' => $thisfn}); |
| #return $env{$cache_str}=''; |
#return $env{$cache_str}=''; |
| #} |
#} |
| #$syval.=$1; |
#$syval.=$1; |
|
Line 7491 sub symbread {
|
Line 8017 sub symbread {
|
| return $env{$cache_str}=$syval; |
return $env{$cache_str}=$syval; |
| } |
} |
| } |
} |
| &appenv('request.ambiguous' => $thisfn); |
&appenv({'request.ambiguous' => $thisfn}); |
| return $env{$cache_str}=''; |
return $env{$cache_str}=''; |
| } |
} |
| |
|
|
Line 7983 sub repcopy_userfile {
|
Line 8509 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 7998 sub repcopy_userfile {
|
Line 8527 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; |
| my (undef,$udom,$uname,$file)=split('/',$uri,4); |
my (undef,$udom,$uname,$file)=split('/',$uri,4); |
| 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 8021 sub tokenwrapper {
|
Line 8553 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 8063 sub filelocation {
|
Line 8598 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 8071 sub filelocation {
|
Line 8608 sub filelocation {
|
| my @ids=¤t_machine_ids(); |
my @ids=¤t_machine_ids(); |
| foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } } |
foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } } |
| if ($is_me) { |
if ($is_me) { |
| $location=&propath($udom,$uname). |
$location=&propath($udom,$uname).'/userfiles/'.$filename; |
| '/userfiles/'.$filename; |
|
| } else { |
} else { |
| $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'. |
$location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'. |
| $udom.'/'.$uname.'/'.$filename; |
$udom.'/'.$uname.'/'.$filename; |
|
Line 8102 sub filelocation {
|
Line 8638 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 8298 sub get_dns {
|
Line 8834 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 8370 sub get_dns {
|
Line 8911 sub get_dns {
|
| } |
} |
| return $domain{$name}{$what}; |
return $domain{$name}{$what}; |
| } |
} |
| |
|
| |
sub domain_info { |
| |
&load_domain_tab() if (!$loaded); |
| |
return %domain; |
| |
} |
| |
|
| } |
} |
| |
|
| |
|
|
Line 8387 sub get_dns {
|
Line 8934 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)=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'; |
| |
} |
| } |
} |
| } |
} |
| } |
} |
|
Line 8438 sub get_dns {
|
Line 8994 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 8579 sub get_dns {
|
Line 9140 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; |
| |
} |
| |
|
| } |
} |
| |
|
| BEGIN { |
BEGIN { |
|
Line 8668 $memcache=new Cache::Memcached({'servers
|
Line 9254 $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 8835 when the connection is brought back up
|
Line 9422 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 8850 that was requested
|
Line 9437 that was requested
|
| |
|
| =item * |
=item * |
| X<appenv()> |
X<appenv()> |
| B<appenv(%hash)>: the value of %hash is written to |
B<appenv($hashref,$rolesarrayref)>: the value of %{$hashref} is written to |
| the user envirnoment file, and will be restored for each access this |
the user envirnoment file, and will be restored for each access this |
| user makes during this session, also modifies the %env for the current |
user makes during this session, also modifies the %env for the current |
| process |
process. Optional rolesarrayref - if defined contains a reference to an array |
| |
of roles which are exempt from the restriction on modifying user.role entries |
| |
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 8956 and course level
|
Line 9547 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 Group. |
| |
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 8983 provided for types, will default to retu
|
Line 9579 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 9000 modifyuserauth($udom,$uname,$umode,$upas
|
Line 9596 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, |
| |
$forceid,$desiredhome,$email,$inststatus) : |
| modify user |
modify user |
| |
|
| =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 9019 Inputs:
|
Line 9616 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 9047 Inputs:
|
Line 9644 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 9080 Inputs:
|
Line 9691 Inputs:
|
| |
|
| =item $start |
=item $start |
| |
|
| |
=item $type |
| |
|
| |
=item $locktype |
| |
|
| |
=item $cid |
| |
|
| |
=item $selfenroll |
| |
|
| |
=item $context |
| |
|
| =back |
=back |
| |
|
| |
|
|
Line 9388 Returns:
|
Line 10009 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 9442 dirlist($uri) : return directory list ba
|
Line 10063 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