version 1.1172.2.10, 2012/09/02 16:23:02
|
version 1.1193, 2012/10/31 12:54:23
|
Line 75 use LWP::UserAgent();
|
Line 75 use LWP::UserAgent();
|
use HTTP::Date; |
use HTTP::Date; |
use Image::Magick; |
use Image::Magick; |
|
|
|
|
|
use Encode; |
|
|
use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir |
use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir |
$_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease |
$_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease |
%managerstab); |
%managerstab); |
Line 97 use File::MMagic;
|
Line 100 use File::MMagic;
|
use LONCAPA qw(:DEFAULT :match); |
use LONCAPA qw(:DEFAULT :match); |
use LONCAPA::Configuration; |
use LONCAPA::Configuration; |
use LONCAPA::lonmetadata; |
use LONCAPA::lonmetadata; |
|
use LONCAPA::Lond; |
|
|
use File::Copy; |
use File::Copy; |
|
|
Line 108 require Exporter;
|
Line 112 require Exporter;
|
our @ISA = qw (Exporter); |
our @ISA = qw (Exporter); |
our @EXPORT = qw(%env); |
our @EXPORT = qw(%env); |
|
|
|
|
# ------------------------------------ Logging (parameters, docs, slots, roles) |
# ------------------------------------ Logging (parameters, docs, slots, roles) |
{ |
{ |
my $logid; |
my $logid; |
Line 119 our @EXPORT = qw(%env);
|
Line 124 our @EXPORT = qw(%env);
|
$cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; |
$cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; |
} |
} |
} |
} |
$logid++; |
$logid ++; |
my $now = time(); |
my $now = time(); |
my $id=$now.'00000'.$$.'00000'.$logid; |
my $id=$now.'00000'.$$.'00000'.$logid; |
my $logentry = { |
my $logentry = { |
$id => { |
$id => { |
'exe_uname' => $env{'user.name'}, |
'exe_uname' => $env{'user.name'}, |
'exe_udom' => $env{'user.domain'}, |
'exe_udom' => $env{'user.domain'}, |
'exe_time' => $now, |
'exe_time' => $now, |
'exe_ip' => $ENV{'REMOTE_ADDR'}, |
'exe_ip' => $ENV{'REMOTE_ADDR'}, |
'delflag' => $delflag, |
'delflag' => $delflag, |
'logentry' => $storehash, |
'logentry' => $storehash, |
'uname' => $uname, |
'uname' => $uname, |
'udom' => $udom, |
'udom' => $udom, |
} |
} |
}; |
}; |
return &put('nohist_'.$hash_name,$logentry,$cdom,$cnum); |
return &put('nohist_'.$hash_name,$logentry,$cdom,$cnum); |
} |
} |
} |
} |
|
|
Line 1235 sub get_lonbalancer_config {
|
Line 1240 sub get_lonbalancer_config {
|
|
|
sub check_loadbalancing { |
sub check_loadbalancing { |
my ($uname,$udom) = @_; |
my ($uname,$udom) = @_; |
my ($is_balancer,$dom_in_use,$homeintdom,$rule_in_effect, |
my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom, |
$offloadto,$otherserver); |
$rule_in_effect,$offloadto,$otherserver); |
my $lonhost = $perlvar{'lonHostID'}; |
my $lonhost = $perlvar{'lonHostID'}; |
my @hosts = ¤t_machine_ids(); |
my @hosts = ¤t_machine_ids(); |
my $uprimary_id = &Apache::lonnet::domain($udom,'primary'); |
my $uprimary_id = &Apache::lonnet::domain($udom,'primary'); |
Line 1261 sub check_loadbalancing {
|
Line 1266 sub check_loadbalancing {
|
} |
} |
} |
} |
if (ref($result) eq 'HASH') { |
if (ref($result) eq 'HASH') { |
my $currbalancer = $result->{'lonhost'}; |
($is_balancer,$currtargets,$currrules) = |
my $currtargets = $result->{'targets'}; |
&check_balancer_result($result,@hosts); |
my $currrules = $result->{'rules'}; |
|
if ($currbalancer ne '') { |
|
if (grep(/^\Q$currbalancer\E$/,@hosts)) { |
|
$is_balancer = 1; |
|
} |
|
} |
|
if ($is_balancer) { |
if ($is_balancer) { |
if (ref($currrules) eq 'HASH') { |
if (ref($currrules) eq 'HASH') { |
if ($homeintdom) { |
if ($homeintdom) { |
Line 1326 sub check_loadbalancing {
|
Line 1325 sub check_loadbalancing {
|
} |
} |
} |
} |
if (ref($result) eq 'HASH') { |
if (ref($result) eq 'HASH') { |
my $currbalancer = $result->{'lonhost'}; |
($is_balancer,$currtargets,$currrules) = |
my $currtargets = $result->{'targets'}; |
&check_balancer_result($result,@hosts); |
my $currrules = $result->{'rules'}; |
if ($is_balancer) { |
|
|
if ($currbalancer eq $lonhost) { |
|
$is_balancer = 1; |
|
if (ref($currrules) eq 'HASH') { |
if (ref($currrules) eq 'HASH') { |
if ($currrules->{'_LC_internetdom'} ne '') { |
if ($currrules->{'_LC_internetdom'} ne '') { |
$rule_in_effect = $currrules->{'_LC_internetdom'}; |
$rule_in_effect = $currrules->{'_LC_internetdom'}; |
Line 1385 sub check_loadbalancing {
|
Line 1381 sub check_loadbalancing {
|
$is_balancer = 0; |
$is_balancer = 0; |
if ($uname ne '' && $udom ne '') { |
if ($uname ne '' && $udom ne '') { |
if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) { |
if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) { |
|
|
&appenv({'user.loadbalexempt' => $lonhost, |
&appenv({'user.loadbalexempt' => $lonhost, |
'user.loadbalcheck.time' => time}); |
'user.loadbalcheck.time' => time}); |
} |
} |
} |
} |
Line 1395 sub check_loadbalancing {
|
Line 1391 sub check_loadbalancing {
|
return ($is_balancer,$otherserver); |
return ($is_balancer,$otherserver); |
} |
} |
|
|
|
sub check_balancer_result { |
|
my ($result,@hosts) = @_; |
|
my ($is_balancer,$currtargets,$currrules); |
|
if (ref($result) eq 'HASH') { |
|
if ($result->{'lonhost'} ne '') { |
|
my $currbalancer = $result->{'lonhost'}; |
|
if (grep(/^\Q$currbalancer\E$/,@hosts)) { |
|
$is_balancer = 1; |
|
$currtargets = $result->{'targets'}; |
|
$currrules = $result->{'rules'}; |
|
} |
|
} else { |
|
foreach my $key (keys(%{$result})) { |
|
if (($key ne '') && (grep(/^\Q$key\E$/,@hosts)) && |
|
(ref($result->{$key}) eq 'HASH')) { |
|
$is_balancer = 1; |
|
$currrules = $result->{$key}{'rules'}; |
|
$currtargets = $result->{$key}{'targets'}; |
|
last; |
|
} |
|
} |
|
} |
|
} |
|
return ($is_balancer,$currtargets,$currrules); |
|
} |
|
|
sub get_loadbalancer_targets { |
sub get_loadbalancer_targets { |
my ($rule_in_effect,$currtargets,$uname,$udom) = @_; |
my ($rule_in_effect,$currtargets,$uname,$udom) = @_; |
my $offloadto; |
my $offloadto; |
Line 2588 sub ssi {
|
Line 2610 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 $content = $response->content; |
|
|
|
|
if (wantarray) { |
if (wantarray) { |
return ($response->content, $response); |
return ($content, $response); |
} else { |
} else { |
return $response->content; |
return $content; |
} |
} |
} |
} |
|
|
Line 2620 sub allowuploaded {
|
Line 2645 sub allowuploaded {
|
&Apache::lonnet::appenv(\%httpref); |
&Apache::lonnet::appenv(\%httpref); |
} |
} |
|
|
|
# |
|
# Determine if the current user should be able to edit a particular resource, |
|
# when viewing in course context. |
|
# (a) When viewing resource used to determine if "Edit" item is included in |
|
# Functions. |
|
# (b) When displaying folder contents in course editor, used to determine if |
|
# "Edit" link will be displayed alongside resource. |
|
# |
|
# input: 3 args -- filename (decluttered), course number and course domain. |
|
# output: array of four scalars -- |
|
# $cfile -- url for file editing if editable on current server |
|
# $home -- homeserver of resource (i.e., for author if published, |
|
# or course if uploaded.). |
|
# $switchserver -- 1 if server switch will be needed. |
|
# $uploaded -- 1 if resource is a file uploaded to a course. |
|
# |
|
|
|
sub can_edit_resource { |
|
my ($file,$cnum,$cdom) = @_; |
|
my ($cfile,$home,$switchserver,$uploaded); |
|
if ($file ne '') { |
|
if (($cnum =~ /$match_courseid/) && ($cdom =~ /$match_domain/)) { |
|
$uploaded = &is_course_upload($file,$cnum,$cdom); |
|
if ($uploaded) { |
|
$home=&homeserver($cnum,$cdom); |
|
if ($file =~/\.(htm|html|css|js|txt)$/) { |
|
$cfile = &hreflocation('',$file); |
|
} |
|
} |
|
} |
|
unless ($uploaded) { |
|
$file=~s{^(priv/$match_domain/$match_username)}{/$1}; |
|
$file=~s{^($match_domain/$match_username)}{/priv/$1}; |
|
# Check that the user has permission to edit this resource |
|
my $setpriv = 1; |
|
my ($cfuname,$cfudom)=&constructaccess($file,$setpriv); |
|
if (defined($cfudom)) { |
|
$home=&homeserver($cfuname,$cfudom); |
|
$cfile=$file; |
|
} |
|
} |
|
if (($cfile ne '') && (($home ne '') && ($home ne 'no_host'))) { |
|
my @ids=¤t_machine_ids(); |
|
unless (grep(/^\Q$home\E$/,@ids)) { |
|
$switchserver=1; |
|
} |
|
} |
|
} |
|
return ($cfile,$home,$switchserver,$uploaded); |
|
} |
|
|
|
sub is_course_upload { |
|
my ($file,$cnum,$cdom) = @_; |
|
my $uploadpath = &LONCAPA::propath($cdom,$cnum); |
|
$uploadpath =~ s{^\/}{}; |
|
if (($file =~ m{^\Q$uploadpath\E/userfiles/docs/}) || |
|
($file =~ m{^userfiles/\Q$cdom\E/\Q$cnum\E/docs/})) { |
|
return 1; |
|
} |
|
return; |
|
} |
|
|
# --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course |
# --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course |
# input: action, courseID, current domain, intended |
# input: action, courseID, current domain, intended |
# path to file, source of file, instruction to parse file for objects, |
# path to file, source of file, instruction to parse file for objects, |
Line 3856 sub courseiddump {
|
Line 3943 sub courseiddump {
|
|
|
if (($domfilter eq '') || |
if (($domfilter eq '') || |
(&host_domain($tryserver) eq $domfilter)) { |
(&host_domain($tryserver) eq $domfilter)) { |
my $rep = |
my $rep; |
&reply('courseiddump:'.&host_domain($tryserver).':'. |
if (grep { $_ eq $tryserver } current_machine_ids()) { |
$sincefilter.':'.&escape($descfilter).':'. |
$rep = LONCAPA::Lond::dump_course_id_handler( |
&escape($instcodefilter).':'.&escape($ownerfilter). |
join(":", (&host_domain($tryserver), $sincefilter, |
':'.&escape($coursefilter).':'.&escape($typefilter). |
&escape($descfilter), &escape($instcodefilter), |
':'.&escape($regexp_ok).':'.$as_hash.':'. |
&escape($ownerfilter), &escape($coursefilter), |
&escape($selfenrollonly).':'.&escape($catfilter).':'. |
&escape($typefilter), &escape($regexp_ok), |
$showhidden.':'.$caller.':'.&escape($cloner).':'. |
$as_hash, &escape($selfenrollonly), |
&escape($cc_clone).':'.$cloneonly.':'. |
&escape($catfilter), $showhidden, $caller, |
&escape($createdbefore).':'.&escape($createdafter).':'. |
&escape($cloner), &escape($cc_clone), $cloneonly, |
&escape($creationcontext).':'.$domcloner, |
&escape($createdbefore), &escape($createdafter), |
$tryserver); |
&escape($creationcontext), $domcloner))); |
|
} else { |
|
$rep = &reply('courseiddump:'.&host_domain($tryserver).':'. |
|
$sincefilter.':'.&escape($descfilter).':'. |
|
&escape($instcodefilter).':'.&escape($ownerfilter). |
|
':'.&escape($coursefilter).':'.&escape($typefilter). |
|
':'.&escape($regexp_ok).':'.$as_hash.':'. |
|
&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 5111 sub del {
|
Line 5212 sub del {
|
|
|
# -------------------------------------------------------------- dump interface |
# -------------------------------------------------------------- dump interface |
|
|
|
sub unserialize { |
|
my ($rep, $escapedkeys) = @_; |
|
|
|
return {} if $rep =~ /^error/; |
|
|
|
my %returnhash=(); |
|
foreach my $item (split /\&/, $rep) { |
|
my ($key, $value) = split(/=/, $item, 2); |
|
$key = unescape($key) unless $escapedkeys; |
|
next if $key =~ /^error: 2 /; |
|
$returnhash{$key} = Apache::lonnet::thaw_unescape($value); |
|
} |
|
#return %returnhash; |
|
return \%returnhash; |
|
} |
|
|
|
# see Lond::dump_with_regexp |
|
# if $escapedkeys hash keys won't get unescaped. |
sub dump { |
sub dump { |
my ($namespace,$udomain,$uname,$regexp,$range)=@_; |
my ($namespace,$udomain,$uname,$regexp,$range,$escapedkeys)=@_; |
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); |
|
|
|
my $reply; |
|
if (grep { $_ eq $uhome } current_machine_ids()) { |
|
# user is hosted on this machine |
|
$reply = LONCAPA::Lond::dump_with_regexp(join(":", ($udomain, |
|
$uname, $namespace, $regexp, $range)), $loncaparevs{$uhome}); |
|
return %{unserialize($reply, $escapedkeys)}; |
|
} |
if ($regexp) { |
if ($regexp) { |
$regexp=&escape($regexp); |
$regexp=&escape($regexp); |
} else { |
} else { |
Line 5128 sub dump {
|
Line 5254 sub dump {
|
if (!($rep =~ /^error/ )) { |
if (!($rep =~ /^error/ )) { |
foreach my $item (@pairs) { |
foreach my $item (@pairs) { |
my ($key,$value)=split(/=/,$item,2); |
my ($key,$value)=split(/=/,$item,2); |
$key = &unescape($key); |
$key = unescape($key) unless $escapedkeys; |
|
#$key = &unescape($key); |
next if ($key =~ /^error: 2 /); |
next if ($key =~ /^error: 2 /); |
$returnhash{$key}=&thaw_unescape($value); |
$returnhash{$key}=&thaw_unescape($value); |
} |
} |
Line 5141 sub dump {
|
Line 5268 sub dump {
|
|
|
sub dumpstore { |
sub dumpstore { |
my ($namespace,$udomain,$uname,$regexp,$range)=@_; |
my ($namespace,$udomain,$uname,$regexp,$range)=@_; |
if (!$udomain) { $udomain=$env{'user.domain'}; } |
# same as dump but keys must be escaped. They may contain colon separated |
if (!$uname) { $uname=$env{'user.name'}; } |
# lists of values that may themself contain colons (e.g. symbs). |
my $uhome=&homeserver($uname,$udomain); |
return &dump($namespace, $udomain, $uname, $regexp, $range, 1); |
if ($regexp) { |
|
$regexp=&escape($regexp); |
|
} else { |
|
$regexp='.'; |
|
} |
|
my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome); |
|
my @pairs=split(/\&/,$rep); |
|
my %returnhash=(); |
|
foreach my $item (@pairs) { |
|
my ($key,$value)=split(/=/,$item,2); |
|
next if ($key =~ /^error: 2 /); |
|
$returnhash{$key}=&thaw_unescape($value); |
|
} |
|
return %returnhash; |
|
} |
} |
|
|
# -------------------------------------------------------------- keys interface |
# -------------------------------------------------------------- keys interface |
Line 5183 sub currentdump {
|
Line 5296 sub currentdump {
|
$sdom = $env{'user.domain'} if (! defined($sdom)); |
$sdom = $env{'user.domain'} if (! defined($sdom)); |
$sname = $env{'user.name'} if (! defined($sname)); |
$sname = $env{'user.name'} if (! defined($sname)); |
my $uhome = &homeserver($sname,$sdom); |
my $uhome = &homeserver($sname,$sdom); |
my $rep=reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome); |
my $rep; |
|
|
|
if (grep { $_ eq $uhome } current_machine_ids()) { |
|
$rep = LONCAPA::Lond::dump_profile_database(join(":", ($sdom, $sname, |
|
$courseid))); |
|
} else { |
|
$rep = reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome); |
|
} |
|
|
return if ($rep =~ /^(error:|no_such_host)/); |
return if ($rep =~ /^(error:|no_such_host)/); |
# |
# |
my %returnhash=(); |
my %returnhash=(); |
Line 5714 sub usertools_access {
|
Line 5835 sub usertools_access {
|
|
|
my ($toolstatus,$inststatus,$envkey); |
my ($toolstatus,$inststatus,$envkey); |
if ($context eq 'requestauthor') { |
if ($context eq 'requestauthor') { |
$envkey = $context; |
$envkey = $context; |
} else { |
} else { |
$envkey = $context.'.'.$tool; |
$envkey = $context.'.'.$tool; |
} |
} |
Line 6452 sub allowed {
|
Line 6573 sub allowed {
|
return 'F'; |
return 'F'; |
} |
} |
|
|
|
# ------------------------------------------- Check construction space access |
|
|
|
sub constructaccess { |
|
my ($url,$setpriv)=@_; |
|
|
|
# We do not allow editing of previous versions of files |
|
if ($url=~/\.(\d+)\.(\w+)$/) { return ''; } |
|
|
|
# Get username and domain from URL |
|
my ($ownername,$ownerdomain,$ownerhome); |
|
|
|
($ownerdomain,$ownername) = |
|
($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E|)/priv/($match_domain)/($match_username)/}); |
|
|
|
# The URL does not really point to any authorspace, forget it |
|
unless (($ownername) && ($ownerdomain)) { return ''; } |
|
|
|
# Now we need to see if the user has access to the authorspace of |
|
# $ownername at $ownerdomain |
|
|
|
if (($ownername eq $env{'user.name'}) && ($ownerdomain eq $env{'user.domain'})) { |
|
# Real author for this? |
|
$ownerhome = $env{'user.home'}; |
|
if (exists($env{'user.priv.au./'.$ownerdomain.'/./'})) { |
|
return ($ownername,$ownerdomain,$ownerhome); |
|
} |
|
} else { |
|
# Co-author for this? |
|
if (exists($env{'user.priv.ca./'.$ownerdomain.'/'.$ownername.'./'}) || |
|
exists($env{'user.priv.aa./'.$ownerdomain.'/'.$ownername.'./'}) ) { |
|
$ownerhome = &homeserver($ownername,$ownerdomain); |
|
return ($ownername,$ownerdomain,$ownerhome); |
|
} |
|
} |
|
|
|
# We don't have any access right now. If we are not possibly going to do anything about this, |
|
# we might as well leave |
|
unless ($setpriv) { return ''; } |
|
|
|
# Backdoor access? |
|
my $allowed=&allowed('eco',$ownerdomain); |
|
# Nope |
|
unless ($allowed) { return ''; } |
|
# Looks like we may have access, but could be locked by the owner of the construction space |
|
if ($allowed eq 'U') { |
|
my %blocked=&get('environment',['domcoord.author'], |
|
$ownerdomain,$ownername); |
|
# Is blocked by owner |
|
if ($blocked{'domcoord.author'} eq 'blocked') { return ''; } |
|
} |
|
if (($allowed eq 'F') || ($allowed eq 'U')) { |
|
# Grant temporary access |
|
my $then=$env{'user.login.time'}; |
|
my $update==$env{'user.update.time'}; |
|
if (!$update) { $update = $then; } |
|
my $refresh=$env{'user.refresh.time'}; |
|
if (!$refresh) { $refresh = $update; } |
|
my $now = time; |
|
&check_adhoc_privs($ownerdomain,$ownername,$update,$refresh, |
|
$now,'ca','constructaccess'); |
|
$ownerhome = &homeserver($ownername,$ownerdomain); |
|
return($ownername,$ownerdomain,$ownerhome); |
|
} |
|
# No business here |
|
return ''; |
|
} |
|
|
sub get_comm_blocks { |
sub get_comm_blocks { |
my ($cdom,$cnum) = @_; |
my ($cdom,$cnum) = @_; |
if ($cdom eq '' || $cnum eq '') { |
if ($cdom eq '' || $cnum eq '') { |
Line 7517 sub assignrole {
|
Line 7705 sub assignrole {
|
} |
} |
} |
} |
} elsif ($context eq 'requestauthor') { |
} elsif ($context eq 'requestauthor') { |
if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) && |
if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) && |
($url eq '/'.$udom.'/') && ($role eq 'au')) { |
($url eq '/'.$udom.'/') && ($role eq 'au')) { |
if ($env{'environment.requestauthor'} eq 'automatic') { |
if ($env{'environment.requestauthor'} eq 'automatic') { |
$refused = ''; |
$refused = ''; |
Line 7525 sub assignrole {
|
Line 7713 sub assignrole {
|
my %domdefaults = &get_domain_defaults($udom); |
my %domdefaults = &get_domain_defaults($udom); |
if (ref($domdefaults{'requestauthor'}) eq 'HASH') { |
if (ref($domdefaults{'requestauthor'}) eq 'HASH') { |
my $checkbystatus; |
my $checkbystatus; |
if ($env{'user.adv'}) { |
if ($env{'user.adv'}) { |
my $disposition = $domdefaults{'requestauthor'}{'_LC_adv'}; |
my $disposition = $domdefaults{'requestauthor'}{'_LC_adv'}; |
if ($disposition eq 'automatic') { |
if ($disposition eq 'automatic') { |
$refused = ''; |
$refused = ''; |
} elsif ($disposition eq '') { |
} elsif ($disposition eq '') { |
$checkbystatus = 1; |
$checkbystatus = 1; |
} |
} |
} else { |
} else { |
$checkbystatus = 1; |
$checkbystatus = 1; |
} |
} |
Line 7618 sub assignrole {
|
Line 7806 sub assignrole {
|
$context); |
$context); |
} elsif (($role eq 'ca') || ($role eq 'aa')) { |
} elsif (($role eq 'ca') || ($role eq 'aa')) { |
&coauthorrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag, |
&coauthorrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag, |
$context); |
$context); |
} |
} |
if ($role eq 'cc') { |
if ($role eq 'cc') { |
&autoupdate_coowners($url,$end,$start,$uname,$udom); |
&autoupdate_coowners($url,$end,$start,$uname,$udom); |
Line 9976 sub symblist {
|
Line 10164 sub symblist {
|
# --------------------------------------------------------------- Verify a symb |
# --------------------------------------------------------------- Verify a symb |
|
|
sub symbverify { |
sub symbverify { |
my ($symb,$thisurl)=@_; |
my ($symb,$thisurl,$encstate)=@_; |
my $thisfn=$thisurl; |
my $thisfn=$thisurl; |
$thisfn=&declutter($thisfn); |
$thisfn=&declutter($thisfn); |
# direct jump to resource in page or to a sequence - will construct own symbs |
# direct jump to resource in page or to a sequence - will construct own symbs |
Line 10012 sub symbverify {
|
Line 10200 sub symbverify {
|
} |
} |
if ( |
if ( |
&symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn) |
&symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn) |
eq $symb) { |
eq $symb) { |
|
if (ref($encstate)) { |
|
$$encstate = $bighash{'encrypted_'.$id}; |
|
} |
if (($env{'request.role.adv'}) || |
if (($env{'request.role.adv'}) || |
($bighash{'encrypted_'.$id} eq $env{'request.enc'}) || |
($bighash{'encrypted_'.$id} eq $env{'request.enc'}) || |
($thisurl eq '/adm/navmaps')) { |
($thisurl eq '/adm/navmaps')) { |
$okay=1; |
$okay=1; |
} |
} |
} |
} |
} |
} |
Line 11880 allowed($priv,$uri,$symb,$role) : check
|
Line 12071 allowed($priv,$uri,$symb,$role) : check
|
|
|
=item * |
=item * |
|
|
|
constructaccess($url,$setpriv) : check for access to construction space URL |
|
|
|
See if the owner domain and name in the URL match those in the |
|
expected environment. If so, return three element list |
|
($ownername,$ownerdomain,$ownerhome). |
|
|
|
Otherwise return the null string. |
|
|
|
If second argument 'setpriv' is true, it assigns the privileges, |
|
and returns the same three element list, unless the owner has |
|
blocked "ad hoc" Domain Coordinator access to the Author Space, |
|
in which case the null string is returned. |
|
|
|
=item * |
|
|
definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom |
definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom |
role rolename set privileges in format of lonTabs/roles.tab for system, domain, |
role rolename set privileges in format of lonTabs/roles.tab for system, domain, |
and course level |
and course level |
Line 12213 returns the data handle
|
Line 12419 returns the data handle
|
|
|
=item * |
=item * |
|
|
symbverify($symb,$thisfn) : verifies that $symb actually exists and is |
symbverify($symb,$thisfn,$encstate) : verifies that $symb actually exists |
a possible symb for the URL in $thisfn, and if is an encryypted |
and is a possible symb for the URL in $thisfn, and if is an encrypted |
resource that the user accessed using /enc/ returns a 1 on success, 0 |
resource that the user accessed using /enc/ returns a 1 on success, 0 |
on failure, user must be in a course, as it assumes the existance of |
on failure, user must be in a course, as it assumes the existence of |
the course initial hash, and uses $env('request.course.id'} |
the course initial hash, and uses $env('request.course.id'}. The third |
|
arg is an optional reference to a scalar. If this arg is passed in the |
|
call to symbverify, it will be set to 1 if the symb has been set to be |
|
encrypted; otherwise it will be null. |
|
|
=item * |
=item * |
|
|