version 1.782.2.4, 2006/10/20 20:39:44
|
version 1.833, 2007/02/18 01:51:20
|
Line 52 use Storable qw(lock_store lock_nstore l
|
Line 52 use Storable qw(lock_store lock_nstore l
|
use Time::HiRes qw( gettimeofday tv_interval ); |
use Time::HiRes qw( gettimeofday tv_interval ); |
use Cache::Memcached; |
use Cache::Memcached; |
use Digest::MD5; |
use Digest::MD5; |
use lib '/home/httpd/lib/perl'; |
use Math::Random; |
use LONCAPA; |
use LONCAPA qw(:DEFAULT :match); |
use LONCAPA::Configuration; |
use LONCAPA::Configuration; |
|
|
my $readit; |
my $readit; |
Line 292 sub error {
|
Line 292 sub error {
|
return undef; |
return undef; |
} |
} |
|
|
|
sub convert_and_load_session_env { |
|
my ($lonidsdir,$handle)=@_; |
|
my @profile; |
|
{ |
|
open(my $idf,"$lonidsdir/$handle.id"); |
|
flock($idf,LOCK_SH); |
|
@profile=<$idf>; |
|
close($idf); |
|
} |
|
my %temp_env; |
|
foreach my $line (@profile) { |
|
if ($line !~ m/=/) { |
|
return 0; |
|
} |
|
chomp($line); |
|
my ($envname,$envvalue)=split(/=/,$line,2); |
|
$temp_env{&unescape($envname)} = &unescape($envvalue); |
|
} |
|
unlink("$lonidsdir/$handle.id"); |
|
if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_WRCREAT(), |
|
0640)) { |
|
%disk_env = %temp_env; |
|
@env{keys(%temp_env)} = @disk_env{keys(%temp_env)}; |
|
untie(%disk_env); |
|
} |
|
return 1; |
|
} |
|
|
# ------------------------------------------- Transfer profile into environment |
# ------------------------------------------- Transfer profile into environment |
my $env_loaded; |
my $env_loaded; |
sub transfer_profile_to_env { |
sub transfer_profile_to_env { |
Line 305 sub transfer_profile_to_env {
|
Line 333 sub transfer_profile_to_env {
|
($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| ); |
($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| ); |
} |
} |
|
|
my @profile; |
my $convert; |
{ |
{ |
open(my $idf,"$lonidsdir/$handle.id"); |
open(my $idf,"$lonidsdir/$handle.id"); |
flock($idf,LOCK_SH); |
flock($idf,LOCK_SH); |
@profile=<$idf>; |
if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id", |
close($idf); |
&GDBM_READER(),0640)) { |
|
@env{keys(%disk_env)} = @disk_env{keys(%disk_env)}; |
|
untie(%disk_env); |
|
} else { |
|
$convert = 1; |
|
} |
|
} |
|
if ($convert) { |
|
if (!&convert_and_load_session_env($lonidsdir,$handle)) { |
|
&logthis("Failed to load session, or convert session."); |
|
} |
} |
} |
my $envi; |
|
my %Remove; |
my %remove; |
for ($envi=0;$envi<=$#profile;$envi++) { |
while ( my $envname = each(%env) ) { |
chomp($profile[$envi]); |
|
my ($envname,$envvalue)=split(/=/,$profile[$envi],2); |
|
$envname=&unescape($envname); |
|
$envvalue=&unescape($envvalue); |
|
$env{$envname} = $envvalue; |
|
if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) { |
if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) { |
if ($time < time-300) { |
if ($time < time-300) { |
$Remove{$key}++; |
$remove{$key}++; |
} |
} |
} |
} |
} |
} |
|
|
$env{'user.environment'} = "$lonidsdir/$handle.id"; |
$env{'user.environment'} = "$lonidsdir/$handle.id"; |
$env_loaded=1; |
$env_loaded=1; |
foreach my $expired_key (keys(%Remove)) { |
foreach my $expired_key (keys(%remove)) { |
&delenv($expired_key); |
&delenv($expired_key); |
} |
} |
} |
} |
|
|
|
sub timed_flock { |
|
my ($file,$lock_type) = @_; |
|
my $failed=0; |
|
eval { |
|
local $SIG{__DIE__}='DEFAULT'; |
|
local $SIG{ALRM}=sub { |
|
$failed=1; |
|
die("failed lock"); |
|
}; |
|
alarm(13); |
|
flock($file,$lock_type); |
|
alarm(0); |
|
}; |
|
if ($failed) { |
|
return undef; |
|
} else { |
|
return 1; |
|
} |
|
} |
|
|
# ---------------------------------------------------------- Append Environment |
# ---------------------------------------------------------- Append Environment |
|
|
sub appenv { |
sub appenv { |
Line 347 sub appenv {
|
Line 401 sub appenv {
|
$env{$key}=$newenv{$key}; |
$env{$key}=$newenv{$key}; |
} |
} |
} |
} |
foreach my $key (keys(%newenv)) { |
open(my $env_file,$env{'user.environment'}); |
my $value = &escape($newenv{$key}); |
if (&timed_flock($env_file,LOCK_EX) |
delete($newenv{$key}); |
&& |
$newenv{&escape($key)}=$value; |
tie(my %disk_env,'GDBM_File',$env{'user.environment'}, |
} |
(&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { |
|
while (my ($key,$value) = each(%newenv)) { |
my $lockfh; |
$disk_env{$key} = $value; |
unless (open($lockfh,"$env{'user.environment'}")) { |
|
return 'error: '.$!; |
|
} |
|
unless (flock($lockfh,LOCK_EX)) { |
|
&logthis("<font color=\"blue\">WARNING: ". |
|
'Could not obtain exclusive lock in appenv: '.$!); |
|
close($lockfh); |
|
return 'error: '.$!; |
|
} |
|
|
|
my @oldenv; |
|
{ |
|
my $fh; |
|
unless (open($fh,"$env{'user.environment'}")) { |
|
return 'error: '.$!; |
|
} |
|
@oldenv=<$fh>; |
|
close($fh); |
|
} |
|
for (my $i=0; $i<=$#oldenv; $i++) { |
|
chomp($oldenv[$i]); |
|
if ($oldenv[$i] ne '') { |
|
my ($name,$value)=split(/=/,$oldenv[$i],2); |
|
unless (defined($newenv{$name})) { |
|
$newenv{$name}=$value; |
|
} |
|
} |
|
} |
|
{ |
|
my $fh; |
|
unless (open($fh,">$env{'user.environment'}")) { |
|
return 'error'; |
|
} |
|
my $newname; |
|
foreach $newname (keys %newenv) { |
|
print $fh $newname.'='.$newenv{$newname}."\n"; |
|
} |
} |
close($fh); |
untie(%disk_env); |
} |
} |
|
|
close($lockfh); |
|
return 'ok'; |
return 'ok'; |
} |
} |
# ----------------------------------------------------- Delete from Environment |
# ----------------------------------------------------- Delete from Environment |
Line 406 sub delenv {
|
Line 422 sub delenv {
|
"Attempt to delete from environment ".$delthis); |
"Attempt to delete from environment ".$delthis); |
return 'error'; |
return 'error'; |
} |
} |
my @oldenv; |
open(my $env_file,$env{'user.environment'}); |
{ |
if (&timed_flock($env_file,LOCK_EX) |
my $fh; |
&& |
unless (open($fh,"$env{'user.environment'}")) { |
tie(my %disk_env,'GDBM_File',$env{'user.environment'}, |
return 'error'; |
(&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { |
} |
foreach my $key (keys(%disk_env)) { |
unless (flock($fh,LOCK_SH)) { |
if ($key=~/^$delthis/) { |
&logthis("<font color=\"blue\">WARNING: ". |
|
'Could not obtain shared lock in delenv: '.$!); |
|
close($fh); |
|
return 'error: '.$!; |
|
} |
|
@oldenv=<$fh>; |
|
close($fh); |
|
} |
|
{ |
|
my $fh; |
|
unless (open($fh,">$env{'user.environment'}")) { |
|
return 'error'; |
|
} |
|
unless (flock($fh,LOCK_EX)) { |
|
&logthis("<font color=\"blue\">WARNING: ". |
|
'Could not obtain exclusive lock in delenv: '.$!); |
|
close($fh); |
|
return 'error: '.$!; |
|
} |
|
foreach my $cur_key (@oldenv) { |
|
my $unescaped_cur_key = &unescape($cur_key); |
|
if ($unescaped_cur_key=~/^$delthis/) { |
|
my ($key) = split('=',$cur_key,2); |
|
$key = &unescape($key); |
|
delete($env{$key}); |
delete($env{$key}); |
} else { |
delete($disk_env{$key}); |
print $fh $cur_key; |
|
} |
} |
} |
} |
close($fh); |
untie(%disk_env); |
} |
} |
return 'ok'; |
return 'ok'; |
} |
} |
|
|
|
sub get_env_multiple { |
|
my ($name) = @_; |
|
my @values; |
|
if (defined($env{$name})) { |
|
# exists is it an array |
|
if (ref($env{$name})) { |
|
@values=@{ $env{$name} }; |
|
} else { |
|
$values[0]=$env{$name}; |
|
} |
|
} |
|
return(@values); |
|
} |
|
|
# ------------------------------------------ Find out current server userload |
# ------------------------------------------ Find out current server userload |
# there is a copy in lond |
# there is a copy in lond |
sub userload { |
sub userload { |
Line 556 sub compare_server_load {
|
Line 561 sub compare_server_load {
|
# --------------------------------------------- Try to change a user's password |
# --------------------------------------------- Try to change a user's password |
|
|
sub changepass { |
sub changepass { |
my ($uname,$udom,$currentpass,$newpass,$server)=@_; |
my ($uname,$udom,$currentpass,$newpass,$server,$context)=@_; |
$currentpass = &escape($currentpass); |
$currentpass = &escape($currentpass); |
$newpass = &escape($newpass); |
$newpass = &escape($newpass); |
my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass", |
my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context", |
$server); |
$server); |
if (! $answer) { |
if (! $answer) { |
&logthis("No reply on password change request to $server ". |
&logthis("No reply on password change request to $server ". |
Line 608 sub queryauthenticate {
|
Line 613 sub queryauthenticate {
|
|
|
sub authenticate { |
sub authenticate { |
my ($uname,$upass,$udom)=@_; |
my ($uname,$upass,$udom)=@_; |
$upass=escape($upass); |
$upass=&escape($upass); |
$uname=~s/\W//g; |
$uname= &LONCAPA::clean_username($uname); |
my $uhome=&homeserver($uname,$udom); |
my $uhome=&homeserver($uname,$udom); |
if (!$uhome) { |
if (!$uhome) { |
&logthis("User $uname at $udom is unknown in authenticate"); |
&logthis("User $uname at $udom is unknown in authenticate"); |
Line 684 sub idget {
|
Line 689 sub idget {
|
sub idrget { |
sub idrget { |
my ($udom,@unames)=@_; |
my ($udom,@unames)=@_; |
my %returnhash=(); |
my %returnhash=(); |
foreach (@unames) { |
foreach my $uname (@unames) { |
$returnhash{$_}=(&userenvironment($udom,$_,'id'))[1]; |
$returnhash{$uname}=(&userenvironment($udom,$uname,'id'))[1]; |
} |
} |
return %returnhash; |
return %returnhash; |
} |
} |
Line 695 sub idrget {
|
Line 700 sub idrget {
|
sub idput { |
sub idput { |
my ($udom,%ids)=@_; |
my ($udom,%ids)=@_; |
my %servers=(); |
my %servers=(); |
foreach (keys %ids) { |
foreach my $uname (keys(%ids)) { |
&cput('environment',{'id'=>$ids{$_}},$udom,$_); |
&cput('environment',{'id'=>$ids{$uname}},$udom,$uname); |
my $uhom=&homeserver($_,$udom); |
my $uhom=&homeserver($uname,$udom); |
if ($uhom ne 'no_host') { |
if ($uhom ne 'no_host') { |
my $id=&escape($ids{$_}); |
my $id=&escape($ids{$uname}); |
$id=~tr/A-Z/a-z/; |
$id=~tr/A-Z/a-z/; |
my $unam=&escape($_); |
my $esc_unam=&escape($uname); |
if ($servers{$uhom}) { |
if ($servers{$uhom}) { |
$servers{$uhom}.='&'.$id.'='.$unam; |
$servers{$uhom}.='&'.$id.'='.$esc_unam; |
} else { |
} else { |
$servers{$uhom}=$id.'='.$unam; |
$servers{$uhom}=$id.'='.$esc_unam; |
} |
} |
} |
} |
} |
} |
foreach (keys %servers) { |
foreach my $server (keys(%servers)) { |
&critical('idput:'.$udom.':'.$servers{$_},$_); |
&critical('idput:'.$udom.':'.$servers{$server},$server); |
|
} |
|
} |
|
|
|
# ------------------------------------------- get items from domain db files |
|
|
|
sub get_dom { |
|
my ($namespace,$storearr,$udom)=@_; |
|
my $items=''; |
|
foreach my $item (@$storearr) { |
|
$items.=&escape($item).'&'; |
|
} |
|
$items=~s/\&$//; |
|
if (!$udom) { $udom=$env{'user.domain'}; } |
|
if (exists($domain_primary{$udom})) { |
|
my $uhome=$domain_primary{$udom}; |
|
my $rep=&reply("getdom:$udom:$namespace:$items",$uhome); |
|
my @pairs=split(/\&/,$rep); |
|
if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) { |
|
return @pairs; |
|
} |
|
my %returnhash=(); |
|
my $i=0; |
|
foreach my $item (@$storearr) { |
|
$returnhash{$item}=&thaw_unescape($pairs[$i]); |
|
$i++; |
|
} |
|
return %returnhash; |
|
} else { |
|
&logthis("get_dom failed - no primary domain server for $udom"); |
|
} |
|
} |
|
|
|
# -------------------------------------------- put items in domain db files |
|
|
|
sub put_dom { |
|
my ($namespace,$storehash,$udom)=@_; |
|
if (!$udom) { $udom=$env{'user.domain'}; } |
|
if (exists($domain_primary{$udom})) { |
|
my $uhome=$domain_primary{$udom}; |
|
my $items=''; |
|
foreach my $item (keys(%$storehash)) { |
|
$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; |
|
} |
|
$items=~s/\&$//; |
|
return &reply("putdom:$udom:$namespace:$items",$uhome); |
|
} else { |
|
&logthis("put_dom failed - no primary domain server for $udom"); |
} |
} |
} |
} |
|
|
Line 847 sub validate_access_key {
|
Line 899 sub validate_access_key {
|
# ------------------------------------- Find the section of student in a course |
# ------------------------------------- Find the section of student in a course |
sub devalidate_getsection_cache { |
sub devalidate_getsection_cache { |
my ($udom,$unam,$courseid)=@_; |
my ($udom,$unam,$courseid)=@_; |
$courseid=~s/\_/\//g; |
|
$courseid=~s/^(\w)/\/$1/; |
|
my $hashid="$udom:$unam:$courseid"; |
my $hashid="$udom:$unam:$courseid"; |
&devalidate_cache_new('getsection',$hashid); |
&devalidate_cache_new('getsection',$hashid); |
} |
} |
|
|
|
sub courseid_to_courseurl { |
|
my ($courseid) = @_; |
|
#already url style courseid |
|
return $courseid if ($courseid =~ m{^/}); |
|
|
|
if (exists($env{'course.'.$courseid.'.num'})) { |
|
my $cnum = $env{'course.'.$courseid.'.num'}; |
|
my $cdom = $env{'course.'.$courseid.'.domain'}; |
|
return "/$cdom/$cnum"; |
|
} |
|
|
|
my %courseinfo=&Apache::lonnet::coursedescription($courseid); |
|
if (exists($courseinfo{'num'})) { |
|
return "/$courseinfo{'domain'}/$courseinfo{'num'}"; |
|
} |
|
|
|
return undef; |
|
} |
|
|
sub getsection { |
sub getsection { |
my ($udom,$unam,$courseid)=@_; |
my ($udom,$unam,$courseid)=@_; |
my $cachetime=1800; |
my $cachetime=1800; |
$courseid=~s/\_/\//g; |
|
$courseid=~s/^(\w)/\/$1/; |
|
|
|
my $hashid="$udom:$unam:$courseid"; |
my $hashid="$udom:$unam:$courseid"; |
my ($result,$cached)=&is_cached_new('getsection',$hashid); |
my ($result,$cached)=&is_cached_new('getsection',$hashid); |
Line 878 sub getsection {
|
Line 945 sub getsection {
|
# If there is more than one expired role, choose the one which ended last. |
# If there is more than one expired role, choose the one which ended last. |
# If there is a role which has expired, return it. |
# If there is a role which has expired, return it. |
# |
# |
foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles', |
$courseid = &courseid_to_courseurl($courseid); |
&homeserver($unam,$udom)))) { |
my %roleshash = &dump('roles',$udom,$unam,$courseid); |
my ($key,$value)=split(/\=/,$_); |
foreach my $key (keys(%roleshash)) { |
$key=&unescape($key); |
|
next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/); |
next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/); |
my $section=$1; |
my $section=$1; |
if ($key eq $courseid.'_st') { $section=''; } |
if ($key eq $courseid.'_st') { $section=''; } |
my ($dummy,$end,$start)=split(/\_/,&unescape($value)); |
my ($dummy,$end,$start)=split(/\_/,&unescape($roleshash{$key})); |
my $now=time; |
my $now=time; |
if (defined($end) && $end && ($now > $end)) { |
if (defined($end) && $end && ($now > $end)) { |
$Expired{$end}=$section; |
$Expired{$end}=$section; |
Line 1136 sub repcopy {
|
Line 1202 sub repcopy {
|
} |
} |
$filename=~s/[\n\r]//g; |
$filename=~s/[\n\r]//g; |
my $transname="$filename.in.transfer"; |
my $transname="$filename.in.transfer"; |
|
# FIXME: this should flock |
if ((-e $filename) || (-e $transname)) { return 'ok'; } |
if ((-e $filename) || (-e $transname)) { return 'ok'; } |
my $remoteurl=subscribe($filename); |
my $remoteurl=subscribe($filename); |
if ($remoteurl =~ /^con_lost by/) { |
if ($remoteurl =~ /^con_lost by/) { |
Line 1384 sub store_edited_file {
|
Line 1451 sub store_edited_file {
|
} |
} |
|
|
sub clean_filename { |
sub clean_filename { |
my ($fname)=@_; |
my ($fname,$args)=@_; |
# Replace Windows backslashes by forward slashes |
# Replace Windows backslashes by forward slashes |
$fname=~s/\\/\//g; |
$fname=~s/\\/\//g; |
# Get rid of everything but the actual filename |
if (!$args->{'keep_path'}) { |
$fname=~s/^.*\/([^\/]+)$/$1/; |
# Get rid of everything but the actual filename |
|
$fname=~s/^.*\/([^\/]+)$/$1/; |
|
} |
# Replace spaces by underscores |
# Replace spaces by underscores |
$fname=~s/\s+/\_/g; |
$fname=~s/\s+/\_/g; |
# Replace all other weird characters by nothing |
# Replace all other weird characters by nothing |
$fname=~s/[^\w\.\-]//g; |
$fname=~s{[^/\w\.\-]}{}g; |
# Replace all .\d. sequences with _\d. so they no longer look like version |
# Replace all .\d. sequences with _\d. so they no longer look like version |
# numbers |
# numbers |
$fname=~s/\.(\d+)(?=\.)/_$1/g; |
$fname=~s/\.(\d+)(?=\.)/_$1/g; |
Line 1656 sub removeuploadedurl {
|
Line 1725 sub removeuploadedurl {
|
sub removeuserfile { |
sub removeuserfile { |
my ($docuname,$docudom,$fname)=@_; |
my ($docuname,$docudom,$fname)=@_; |
my $home=&homeserver($docuname,$docudom); |
my $home=&homeserver($docuname,$docudom); |
return &reply("removeuserfile:$docudom/$docuname/$fname",$home); |
my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home); |
|
if ($result eq 'ok') { |
|
if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) { |
|
my $metafile = $fname.'.meta'; |
|
my $metaresult = &removeuserfile($docuname,$docudom,$metafile); |
|
my $url = "/uploaded/$docudom/$docuname/$fname"; |
|
my ($file,$group) = (&parse_portfolio_url($url))[3,4]; |
|
my $sqlresult = |
|
&update_portfolio_table($docuname,$docudom,$file, |
|
'portfolio_metadata',$group, |
|
'delete'); |
|
} |
|
} |
|
return $result; |
} |
} |
|
|
sub mkdiruserfile { |
sub mkdiruserfile { |
Line 1668 sub mkdiruserfile {
|
Line 1750 sub mkdiruserfile {
|
sub renameuserfile { |
sub renameuserfile { |
my ($docuname,$docudom,$old,$new)=@_; |
my ($docuname,$docudom,$old,$new)=@_; |
my $home=&homeserver($docuname,$docudom); |
my $home=&homeserver($docuname,$docudom); |
return &reply("renameuserfile:$docudom:$docuname:".&escape("$old").':'. |
my $result = &reply("renameuserfile:$docudom:$docuname:". |
&escape("$new"),$home); |
&escape("$old").':'.&escape("$new"),$home); |
|
if ($result eq 'ok') { |
|
if (($old !~ /\.meta$/) && (&is_portfolio_file($old))) { |
|
my $oldmeta = $old.'.meta'; |
|
my $newmeta = $new.'.meta'; |
|
my $metaresult = |
|
&renameuserfile($docuname,$docudom,$oldmeta,$newmeta); |
|
my $url = "/uploaded/$docudom/$docuname/$old"; |
|
my ($file,$group) = (&parse_portfolio_url($url))[3,4]; |
|
my $sqlresult = |
|
&update_portfolio_table($docuname,$docudom,$file, |
|
'portfolio_metadata',$group, |
|
'delete'); |
|
} |
|
} |
|
return $result; |
} |
} |
|
|
# ------------------------------------------------------------------------- Log |
# ------------------------------------------------------------------------- Log |
Line 1695 sub flushcourselogs {
|
Line 1792 sub flushcourselogs {
|
# times and course titles for all courseids |
# times and course titles for all courseids |
# |
# |
my %courseidbuffer=(); |
my %courseidbuffer=(); |
foreach (keys %courselogs) { |
foreach my $crsid (keys %courselogs) { |
my $crsid=$_; |
|
if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'. |
if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'. |
&escape($courselogs{$crsid}), |
&escape($courselogs{$crsid}), |
$coursehombuf{$crsid}) eq 'ok') { |
$coursehombuf{$crsid}) eq 'ok') { |
Line 1723 sub flushcourselogs {
|
Line 1819 sub flushcourselogs {
|
# Write course id database (reverse lookup) to homeserver of courses |
# Write course id database (reverse lookup) to homeserver of courses |
# Is used in pickcourse |
# Is used in pickcourse |
# |
# |
foreach (keys %courseidbuffer) { |
foreach my $crsid (keys(%courseidbuffer)) { |
&courseidput($hostdom{$_},$courseidbuffer{$_},$_); |
&courseidput($hostdom{$crsid},$courseidbuffer{$crsid},$crsid); |
} |
} |
# |
# |
# File accesses |
# File accesses |
Line 1733 sub flushcourselogs {
|
Line 1829 sub flushcourselogs {
|
foreach my $entry (keys(%accesshash)) { |
foreach my $entry (keys(%accesshash)) { |
if ($entry =~ /___count$/) { |
if ($entry =~ /___count$/) { |
my ($dom,$name); |
my ($dom,$name); |
($dom,$name,undef)=($entry=~m:___(\w+)/(\w+)/(.*)___count$:); |
($dom,$name,undef)= |
|
($entry=~m{___($match_domain)/($match_name)/(.*)___count$}); |
if (! defined($dom) || $dom eq '' || |
if (! defined($dom) || $dom eq '' || |
! defined($name) || $name eq '') { |
! defined($name) || $name eq '') { |
my $cid = $env{'request.course.id'}; |
my $cid = $env{'request.course.id'}; |
Line 1754 sub flushcourselogs {
|
Line 1851 sub flushcourselogs {
|
} |
} |
} |
} |
} else { |
} else { |
my ($dom,$name) = ($entry=~m:___(\w+)/(\w+)/(.*)___(\w+)$:); |
my ($dom,$name) = ($entry=~m{___($match_domain)/($match_name)/(.*)___(\w+)$}); |
my %temphash=($entry => $accesshash{$entry}); |
my %temphash=($entry => $accesshash{$entry}); |
if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') { |
if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') { |
delete $accesshash{$entry}; |
delete $accesshash{$entry}; |
Line 1765 sub flushcourselogs {
|
Line 1862 sub flushcourselogs {
|
# Roles |
# Roles |
# Reverse lookup of user roles for course faculty/staff and co-authorship |
# Reverse lookup of user roles for course faculty/staff and co-authorship |
# |
# |
foreach (keys %userrolehash) { |
foreach my $entry (keys(%userrolehash)) { |
my $entry=$_; |
|
my ($role,$uname,$udom,$runame,$rudom,$rsec)= |
my ($role,$uname,$udom,$runame,$rudom,$rsec)= |
split(/\:/,$entry); |
split(/\:/,$entry); |
if (&Apache::lonnet::put('nohist_userroles', |
if (&Apache::lonnet::put('nohist_userroles', |
Line 1838 sub courseacclog {
|
Line 1934 sub courseacclog {
|
if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|task|page)$/) { |
if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|task|page)$/) { |
$what.=':POST'; |
$what.=':POST'; |
# FIXME: Probably ought to escape things.... |
# FIXME: Probably ought to escape things.... |
foreach (keys %env) { |
foreach my $key (keys(%env)) { |
if ($_=~/^form\.(.*)/) { |
if ($key=~/^form\.(.*)/) { |
$what.=':'.$1.'='.$env{$_}; |
$what.=':'.$1.'='.$env{$key}; |
} |
} |
} |
} |
} elsif ($fnsymb =~ m:^/adm/searchcat:) { |
} elsif ($fnsymb =~ m:^/adm/searchcat:) { |
Line 1902 sub get_course_adv_roles {
|
Line 1998 sub get_course_adv_roles {
|
$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 %nothide=(); |
my %nothide=(); |
foreach (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) { |
foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) { |
$nothide{join(':',split(/[\@\:]/,$_))}=1; |
$nothide{join(':',split(/[\@\:]/,$user))}=1; |
} |
} |
my %returnhash=(); |
my %returnhash=(); |
my %dumphash= |
my %dumphash= |
&dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'}); |
&dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'}); |
my $now=time; |
my $now=time; |
foreach (keys %dumphash) { |
foreach my $entry (keys %dumphash) { |
my ($tend,$tstart)=split(/\:/,$dumphash{$_}); |
my ($tend,$tstart)=split(/\:/,$dumphash{$entry}); |
if (($tstart) && ($tstart<0)) { next; } |
if (($tstart) && ($tstart<0)) { next; } |
if (($tend) && ($tend<$now)) { next; } |
if (($tend) && ($tend<$now)) { next; } |
if (($tstart) && ($now<$tstart)) { next; } |
if (($tstart) && ($now<$tstart)) { next; } |
my ($role,$username,$domain,$section)=split(/\:/,$_); |
my ($role,$username,$domain,$section)=split(/\:/,$entry); |
if ($username eq '' || $domain eq '') { next; } |
if ($username eq '' || $domain eq '') { next; } |
if ((&privileged($username,$domain)) && |
if ((&privileged($username,$domain)) && |
(!$nothide{$username.':'.$domain})) { next; } |
(!$nothide{$username.':'.$domain})) { next; } |
Line 1931 sub get_course_adv_roles {
|
Line 2027 sub get_course_adv_roles {
|
} |
} |
|
|
sub get_my_roles { |
sub get_my_roles { |
my ($uname,$udom)=@_; |
my ($uname,$udom,$types,$roles,$roledoms)=@_; |
unless (defined($uname)) { $uname=$env{'user.name'}; } |
unless (defined($uname)) { $uname=$env{'user.name'}; } |
unless (defined($udom)) { $udom=$env{'user.domain'}; } |
unless (defined($udom)) { $udom=$env{'user.domain'}; } |
my %dumphash= |
my %dumphash= |
&dump('nohist_userroles',$udom,$uname); |
&dump('nohist_userroles',$udom,$uname); |
my %returnhash=(); |
my %returnhash=(); |
my $now=time; |
my $now=time; |
foreach (keys %dumphash) { |
foreach my $entry (keys(%dumphash)) { |
my ($tend,$tstart)=split(/\:/,$dumphash{$_}); |
my ($tend,$tstart)=split(/\:/,$dumphash{$entry}); |
if (($tstart) && ($tstart<0)) { next; } |
if (($tstart) && ($tstart<0)) { next; } |
if (($tend) && ($tend<$now)) { next; } |
my $status = 'active'; |
if (($tstart) && ($now<$tstart)) { next; } |
if (($tend) && ($tend<$now)) { |
my ($role,$username,$domain,$section)=split(/\:/,$_); |
$status = 'previous'; |
|
} |
|
if (($tstart) && ($now<$tstart)) { |
|
$status = 'future'; |
|
} |
|
if (ref($types) eq 'ARRAY') { |
|
if (!grep(/^\Q$status\E$/,@{$types})) { |
|
next; |
|
} |
|
} else { |
|
if ($status ne 'active') { |
|
next; |
|
} |
|
} |
|
my ($role,$username,$domain,$section)=split(/\:/,$entry); |
|
if (ref($roledoms) eq 'ARRAY') { |
|
if (!grep(/^\Q$domain\E$/,@{$roledoms})) { |
|
next; |
|
} |
|
} |
|
if (ref($roles) eq 'ARRAY') { |
|
if (!grep(/^\Q$role\E$/,@{$roles})) { |
|
next; |
|
} |
|
} |
$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend; |
$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend; |
} |
} |
return %returnhash; |
return %returnhash; |
} |
} |
|
|
Line 1964 sub getannounce {
|
Line 2084 sub getannounce {
|
|
|
if (open(my $fh,$perlvar{'lonDocRoot'}.'/announcement.txt')) { |
if (open(my $fh,$perlvar{'lonDocRoot'}.'/announcement.txt')) { |
my $announcement=''; |
my $announcement=''; |
while (<$fh>) { $announcement .=$_; } |
while (my $line = <$fh>) { $announcement .= $line; } |
close($fh); |
close($fh); |
if ($announcement=~/\w/) { |
if ($announcement=~/\w/) { |
return |
return |
Line 1988 sub courseidput {
|
Line 2108 sub courseidput {
|
} |
} |
|
|
sub courseiddump { |
sub courseiddump { |
my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter)=@_; |
my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_; |
my %returnhash=(); |
my %returnhash=(); |
unless ($domfilter) { $domfilter=''; } |
unless ($domfilter) { $domfilter=''; } |
foreach my $tryserver (keys %libserv) { |
foreach my $tryserver (keys %libserv) { |
if ( ($hostidflag == 1 && grep/^$tryserver$/,@{$hostidref}) || (!defined($hostidflag)) ) { |
if ( ($hostidflag == 1 && grep/^$tryserver$/,@{$hostidref}) || (!defined($hostidflag)) ) { |
if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) { |
if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) { |
foreach ( |
foreach my $line ( |
split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'. |
split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'. |
$sincefilter.':'.&escape($descfilter).':'. |
$sincefilter.':'.&escape($descfilter).':'. |
&escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter), |
&escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter).':'.&escape($regexp_ok), |
$tryserver))) { |
$tryserver))) { |
my ($key,$value)=split(/\=/,$_); |
my ($key,$value)=split(/\=/,$line,2); |
if (($key) && ($value)) { |
if (($key) && ($value)) { |
$returnhash{&unescape($key)}=$value; |
$returnhash{&unescape($key)}=$value; |
} |
} |
Line 2028 sub dcmaildump {
|
Line 2148 sub dcmaildump {
|
&escape($enddate).':'; |
&escape($enddate).':'; |
my @esc_senders=map { &escape($_)} @$senders; |
my @esc_senders=map { &escape($_)} @$senders; |
$cmd.=&escape(join('&',@esc_senders)); |
$cmd.=&escape(join('&',@esc_senders)); |
foreach (split(/\&/,&reply($cmd,$domain_primary{$dom}))) { |
foreach my $line (split(/\&/,&reply($cmd,$domain_primary{$dom}))) { |
my ($key,$value) = split(/\=/,$_); |
my ($key,$value) = split(/\=/,$line,2); |
if (($key) && ($value)) { |
if (($key) && ($value)) { |
$returnhash{&unescape($key)} = &unescape($value); |
$returnhash{&unescape($key)} = &unescape($value); |
} |
} |
Line 2052 sub get_domain_roles {
|
Line 2172 sub get_domain_roles {
|
foreach my $tryserver (keys(%libserv)) { |
foreach my $tryserver (keys(%libserv)) { |
if ($hostdom{$tryserver} eq $dom) { |
if ($hostdom{$tryserver} eq $dom) { |
%{$personnel{$tryserver}}=(); |
%{$personnel{$tryserver}}=(); |
foreach ( |
foreach my $line ( |
split(/\&/,&reply('domrolesdump:'.$dom.':'. |
split(/\&/,&reply('domrolesdump:'.$dom.':'. |
&escape($startdate).':'.&escape($enddate).':'. |
&escape($startdate).':'.&escape($enddate).':'. |
&escape($rolelist), $tryserver))) { |
&escape($rolelist), $tryserver))) { |
my($key,$value) = split(/\=/,$_); |
my ($key,$value) = split(/\=/,$line,2); |
if (($key) && ($value)) { |
if (($key) && ($value)) { |
$personnel{$tryserver}{&unescape($key)} = &unescape($value); |
$personnel{$tryserver}{&unescape($key)} = &unescape($value); |
} |
} |
Line 2070 sub get_domain_roles {
|
Line 2190 sub get_domain_roles {
|
|
|
sub get_first_access { |
sub get_first_access { |
my ($type,$argsymb)=@_; |
my ($type,$argsymb)=@_; |
my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser(); |
my ($symb,$courseid,$udom,$uname)=&whichuser(); |
if ($argsymb) { $symb=$argsymb; } |
if ($argsymb) { $symb=$argsymb; } |
my ($map,$id,$res)=&decode_symb($symb); |
my ($map,$id,$res)=&decode_symb($symb); |
if ($type eq 'map') { |
if ($type eq 'map') { |
Line 2084 sub get_first_access {
|
Line 2204 sub get_first_access {
|
|
|
sub set_first_access { |
sub set_first_access { |
my ($type)=@_; |
my ($type)=@_; |
my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser(); |
my ($symb,$courseid,$udom,$uname)=&whichuser(); |
my ($map,$id,$res)=&decode_symb($symb); |
my ($map,$id,$res)=&decode_symb($symb); |
if ($type eq 'map') { |
if ($type eq 'map') { |
$res=&symbread($map); |
$res=&symbread($map); |
Line 2278 sub hash2str {
|
Line 2398 sub hash2str {
|
sub hashref2str { |
sub hashref2str { |
my ($hashref)=@_; |
my ($hashref)=@_; |
my $result='__HASH_REF__'; |
my $result='__HASH_REF__'; |
foreach (sort(keys(%$hashref))) { |
foreach my $key (sort(keys(%$hashref))) { |
if (ref($_) eq 'ARRAY') { |
if (ref($key) eq 'ARRAY') { |
$result.=&arrayref2str($_).'='; |
$result.=&arrayref2str($key).'='; |
} elsif (ref($_) eq 'HASH') { |
} elsif (ref($key) eq 'HASH') { |
$result.=&hashref2str($_).'='; |
$result.=&hashref2str($key).'='; |
} elsif (ref($_)) { |
} elsif (ref($key)) { |
$result.='='; |
$result.='='; |
#print("Got a ref of ".(ref($_))." skipping."); |
#print("Got a ref of ".(ref($key))." skipping."); |
} else { |
} else { |
if ($_) {$result.=&escape($_).'=';} else { last; } |
if ($key) {$result.=&escape($key).'=';} else { last; } |
} |
} |
|
|
if(ref($hashref->{$_}) eq 'ARRAY') { |
if(ref($hashref->{$key}) eq 'ARRAY') { |
$result.=&arrayref2str($hashref->{$_}).'&'; |
$result.=&arrayref2str($hashref->{$key}).'&'; |
} elsif(ref($hashref->{$_}) eq 'HASH') { |
} elsif(ref($hashref->{$key}) eq 'HASH') { |
$result.=&hashref2str($hashref->{$_}).'&'; |
$result.=&hashref2str($hashref->{$key}).'&'; |
} elsif(ref($hashref->{$_})) { |
} elsif(ref($hashref->{$key})) { |
$result.='&'; |
$result.='&'; |
#print("Got a ref of ".(ref($hashref->{$_}))." skipping."); |
#print("Got a ref of ".(ref($hashref->{$key}))." skipping."); |
} else { |
} else { |
$result.=&escape($hashref->{$_}).'&'; |
$result.=&escape($hashref->{$key}).'&'; |
} |
} |
} |
} |
$result=~s/\&$//; |
$result=~s/\&$//; |
Line 2578 sub store {
|
Line 2698 sub store {
|
$$storehash{'host'}=$perlvar{'lonHostID'}; |
$$storehash{'host'}=$perlvar{'lonHostID'}; |
|
|
my $namevalue=''; |
my $namevalue=''; |
foreach (keys %$storehash) { |
foreach my $key (keys(%$storehash)) { |
$namevalue.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&'; |
$namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&'; |
} |
} |
$namevalue=~s/\&$//; |
$namevalue=~s/\&$//; |
&courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue); |
&courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue); |
Line 2614 sub cstore {
|
Line 2734 sub cstore {
|
$$storehash{'host'}=$perlvar{'lonHostID'}; |
$$storehash{'host'}=$perlvar{'lonHostID'}; |
|
|
my $namevalue=''; |
my $namevalue=''; |
foreach (keys %$storehash) { |
foreach my $key (keys(%$storehash)) { |
$namevalue.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&'; |
$namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&'; |
} |
} |
$namevalue=~s/\&$//; |
$namevalue=~s/\&$//; |
&courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue); |
&courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue); |
Line 2647 sub restore {
|
Line 2767 sub restore {
|
my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home"); |
my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home"); |
|
|
my %returnhash=(); |
my %returnhash=(); |
foreach (split(/\&/,$answer)) { |
foreach my $line (split(/\&/,$answer)) { |
my ($name,$value)=split(/\=/,$_); |
my ($name,$value)=split(/\=/,$line); |
$returnhash{&unescape($name)}=&thaw_unescape($value); |
$returnhash{&unescape($name)}=&thaw_unescape($value); |
} |
} |
my $version; |
my $version; |
for ($version=1;$version<=$returnhash{'version'};$version++) { |
for ($version=1;$version<=$returnhash{'version'};$version++) { |
foreach (split(/\:/,$returnhash{$version.':keys'})) { |
foreach my $item (split(/\:/,$returnhash{$version.':keys'})) { |
$returnhash{$_}=$returnhash{$version.':'.$_}; |
$returnhash{$item}=$returnhash{$version.':'.$item}; |
} |
} |
} |
} |
return %returnhash; |
return %returnhash; |
Line 2694 sub coursedescription {
|
Line 2814 sub coursedescription {
|
if (!$args->{'one_time'}) { |
if (!$args->{'one_time'}) { |
$envhash{'course.'.$normalid.'.last_cache'}=time; |
$envhash{'course.'.$normalid.'.last_cache'}=time; |
} |
} |
|
|
if ($chome ne 'no_host') { |
if ($chome ne 'no_host') { |
%returnhash=&dump('environment',$cdomain,$cnum); |
%returnhash=&dump('environment',$cdomain,$cnum); |
if (!exists($returnhash{'con_lost'})) { |
if (!exists($returnhash{'con_lost'})) { |
Line 2729 sub privileged {
|
Line 2850 sub privileged {
|
if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return 0; } |
if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return 0; } |
my $now=time; |
my $now=time; |
if ($rolesdump ne '') { |
if ($rolesdump ne '') { |
foreach (split(/&/,$rolesdump)) { |
foreach my $entry (split(/&/,$rolesdump)) { |
if ($_!~/^rolesdef_/) { |
if ($entry!~/^rolesdef_/) { |
my ($area,$role)=split(/=/,$_); |
my ($area,$role)=split(/=/,$entry); |
$area=~s/\_\w\w$//; |
$area=~s/\_\w\w$//; |
my ($trole,$tend,$tstart)=split(/_/,$role); |
my ($trole,$tend,$tstart)=split(/_/,$role); |
if (($trole eq 'dc') || ($trole eq 'su')) { |
if (($trole eq 'dc') || ($trole eq 'su')) { |
Line 2763 sub rolesinit {
|
Line 2884 sub rolesinit {
|
my $group_privs; |
my $group_privs; |
|
|
if ($rolesdump ne '') { |
if ($rolesdump ne '') { |
foreach (split(/&/,$rolesdump)) { |
foreach my $entry (split(/&/,$rolesdump)) { |
if ($_!~/^rolesdef_/) { |
if ($entry!~/^rolesdef_/) { |
my ($area,$role)=split(/=/,$_); |
my ($area,$role)=split(/=/,$entry); |
$area=~s/\_\w\w$//; |
$area=~s/\_\w\w$//; |
my ($trole,$tend,$tstart,$group_privs); |
my ($trole,$tend,$tstart,$group_privs); |
if ($role=~/^cr/) { |
if ($role=~/^cr/) { |
if ($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|) { |
if ($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|) { |
($trole,my $trest)=($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|); |
($trole,my $trest)=($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|); |
($tend,$tstart)=split('_',$trest); |
($tend,$tstart)=split('_',$trest); |
} else { |
} else { |
$trole=$role; |
$trole=$role; |
Line 2849 sub group_roleprivs {
|
Line 2970 sub group_roleprivs {
|
if (($tend!=0) && ($tend<$now)) { $access = 0; } |
if (($tend!=0) && ($tend<$now)) { $access = 0; } |
if (($tstart!=0) && ($tstart>$now)) { $access=0; } |
if (($tstart!=0) && ($tstart>$now)) { $access=0; } |
if ($access) { |
if ($access) { |
my ($course,$group) = ($area =~ m|(/\w+/\w+)/([^/]+)$|); |
my ($course,$group) = ($area =~ m|(/$match_domain/$match_courseid)/([^/]+)$|); |
$$allgroups{$course}{$group} .=':'.$group_privs; |
$$allgroups{$course}{$group} .=':'.$group_privs; |
} |
} |
} |
} |
Line 2880 sub set_userprivs {
|
Line 3001 sub set_userprivs {
|
if (keys(%{$allgroups}) > 0) { |
if (keys(%{$allgroups}) > 0) { |
foreach my $role (keys %{$allroles}) { |
foreach my $role (keys %{$allroles}) { |
my ($trole,$area,$sec,$extendedarea); |
my ($trole,$area,$sec,$extendedarea); |
if ($role =~ m-^(\w+|cr/\w+/\w+/\w+)\.(/\w+/\w+)(/?\w*)-) { |
if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)-) { |
$trole = $1; |
$trole = $1; |
$area = $2; |
$area = $2; |
$sec = $3; |
$sec = $3; |
Line 2895 sub set_userprivs {
|
Line 3016 sub set_userprivs {
|
} |
} |
} |
} |
} |
} |
foreach (keys(%grouproles)) { |
foreach my $group (keys(%grouproles)) { |
$$allroles{$_} = $grouproles{$_}; |
$$allroles{$group} = $grouproles{$group}; |
} |
} |
foreach (keys %{$allroles}) { |
foreach my $role (keys(%{$allroles})) { |
my %thesepriv=(); |
my %thesepriv; |
if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; } |
if (($role=~/^au/) || ($role=~/^ca/)) { $author=1; } |
foreach (split(/:/,$$allroles{$_})) { |
foreach my $item (split(/:/,$$allroles{$role})) { |
if ($_ ne '') { |
if ($item ne '') { |
my ($privilege,$restrictions)=split(/&/,$_); |
my ($privilege,$restrictions)=split(/&/,$item); |
if ($restrictions eq '') { |
if ($restrictions eq '') { |
$thesepriv{$privilege}='F'; |
$thesepriv{$privilege}='F'; |
} elsif ($thesepriv{$privilege} ne 'F') { |
} elsif ($thesepriv{$privilege} ne 'F') { |
Line 2913 sub set_userprivs {
|
Line 3034 sub set_userprivs {
|
} |
} |
} |
} |
my $thesestr=''; |
my $thesestr=''; |
foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } |
foreach my $priv (keys(%thesepriv)) { |
$userroles->{'user.priv.'.$_} = $thesestr; |
$thesestr.=':'.$priv.'&'.$thesepriv{$priv}; |
|
} |
|
$userroles->{'user.priv.'.$role} = $thesestr; |
} |
} |
return ($author,$adv); |
return ($author,$adv); |
} |
} |
Line 2924 sub set_userprivs {
|
Line 3047 sub set_userprivs {
|
sub get { |
sub get { |
my ($namespace,$storearr,$udomain,$uname)=@_; |
my ($namespace,$storearr,$udomain,$uname)=@_; |
my $items=''; |
my $items=''; |
foreach (@$storearr) { |
foreach my $item (@$storearr) { |
$items.=escape($_).'&'; |
$items.=&escape($item).'&'; |
} |
} |
$items=~s/\&$//; |
$items=~s/\&$//; |
if (!$udomain) { $udomain=$env{'user.domain'}; } |
if (!$udomain) { $udomain=$env{'user.domain'}; } |
Line 2939 sub get {
|
Line 3062 sub get {
|
} |
} |
my %returnhash=(); |
my %returnhash=(); |
my $i=0; |
my $i=0; |
foreach (@$storearr) { |
foreach my $item (@$storearr) { |
$returnhash{$_}=&thaw_unescape($pairs[$i]); |
$returnhash{$item}=&thaw_unescape($pairs[$i]); |
$i++; |
$i++; |
} |
} |
return %returnhash; |
return %returnhash; |
Line 2951 sub get {
|
Line 3074 sub get {
|
sub del { |
sub del { |
my ($namespace,$storearr,$udomain,$uname)=@_; |
my ($namespace,$storearr,$udomain,$uname)=@_; |
my $items=''; |
my $items=''; |
foreach (@$storearr) { |
foreach my $item (@$storearr) { |
$items.=escape($_).'&'; |
$items.=&escape($item).'&'; |
} |
} |
$items=~s/\&$//; |
$items=~s/\&$//; |
if (!$udomain) { $udomain=$env{'user.domain'}; } |
if (!$udomain) { $udomain=$env{'user.domain'}; } |
Line 2990 sub dump {
|
Line 3113 sub dump {
|
|
|
sub dumpstore { |
sub dumpstore { |
my ($namespace,$udomain,$uname,$regexp,$range)=@_; |
my ($namespace,$udomain,$uname,$regexp,$range)=@_; |
return &dump($namespace,$udomain,$uname,$regexp,$range); |
if (!$udomain) { $udomain=$env{'user.domain'}; } |
|
if (!$uname) { $uname=$env{'user.name'}; } |
|
my $uhome=&homeserver($uname,$udomain); |
|
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 3002 sub getkeys {
|
Line 3141 sub getkeys {
|
my $uhome=&homeserver($uname,$udomain); |
my $uhome=&homeserver($uname,$udomain); |
my $rep=reply("keys:$udomain:$uname:$namespace",$uhome); |
my $rep=reply("keys:$udomain:$uname:$namespace",$uhome); |
my @keyarray=(); |
my @keyarray=(); |
foreach (split(/\&/,$rep)) { |
foreach my $key (split(/\&/,$rep)) { |
push (@keyarray,&unescape($_)); |
next if ($key =~ /^error: 2 /); |
|
push(@keyarray,&unescape($key)); |
} |
} |
return @keyarray; |
return @keyarray; |
} |
} |
Line 3023 sub currentdump {
|
Line 3163 sub currentdump {
|
if ($rep eq "unknown_cmd") { |
if ($rep eq "unknown_cmd") { |
# an old lond will not know currentdump |
# an old lond will not know currentdump |
# Do a dump and make it look like a currentdump |
# Do a dump and make it look like a currentdump |
my @tmp = &dump($courseid,$sdom,$sname,'.'); |
my @tmp = &dumpstore($courseid,$sdom,$sname,'.'); |
return if ($tmp[0] =~ /^(error:|no_such_host)/); |
return if ($tmp[0] =~ /^(error:|no_such_host)/); |
my %hash = @tmp; |
my %hash = @tmp; |
@tmp=(); |
@tmp=(); |
%returnhash = %{&convert_dump_to_currentdump(\%hash)}; |
%returnhash = %{&convert_dump_to_currentdump(\%hash)}; |
} else { |
} else { |
my @pairs=split(/\&/,$rep); |
my @pairs=split(/\&/,$rep); |
foreach (@pairs) { |
foreach my $pair (@pairs) { |
my ($key,$value)=split(/=/,$_); |
my ($key,$value)=split(/=/,$pair,2); |
my ($symb,$param) = split(/:/,$key); |
my ($symb,$param) = split(/:/,$key); |
$returnhash{&unescape($symb)}->{&unescape($param)} = |
$returnhash{&unescape($symb)}->{&unescape($param)} = |
&thaw_unescape($value); |
&thaw_unescape($value); |
Line 3048 sub convert_dump_to_currentdump{
|
Line 3188 sub convert_dump_to_currentdump{
|
# we might run in to problems with parameter names =~ /^v\./ |
# we might run in to problems with parameter names =~ /^v\./ |
while (my ($key,$value) = each(%hash)) { |
while (my ($key,$value) = each(%hash)) { |
my ($v,$symb,$param) = split(/:/,$key); |
my ($v,$symb,$param) = split(/:/,$key); |
|
$symb = &unescape($symb); |
|
$param = &unescape($param); |
next if ($v eq 'version' || $symb eq 'keys'); |
next if ($v eq 'version' || $symb eq 'keys'); |
next if (exists($returnhash{$symb}) && |
next if (exists($returnhash{$symb}) && |
exists($returnhash{$symb}->{$param}) && |
exists($returnhash{$symb}->{$param}) && |
Line 3109 sub put {
|
Line 3251 sub put {
|
if (!$uname) { $uname=$env{'user.name'}; } |
if (!$uname) { $uname=$env{'user.name'}; } |
my $uhome=&homeserver($uname,$udomain); |
my $uhome=&homeserver($uname,$udomain); |
my $items=''; |
my $items=''; |
foreach (keys %$storehash) { |
foreach my $item (keys(%$storehash)) { |
$items.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&'; |
$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; |
} |
} |
$items=~s/\&$//; |
$items=~s/\&$//; |
return &reply("put:$udomain:$uname:$namespace:$items",$uhome); |
return &reply("put:$udomain:$uname:$namespace:$items",$uhome); |
Line 3162 sub old_putstore {
|
Line 3304 sub old_putstore {
|
if (!$uname) { $uname=$env{'user.name'}; } |
if (!$uname) { $uname=$env{'user.name'}; } |
my $uhome=&homeserver($uname,$udomain); |
my $uhome=&homeserver($uname,$udomain); |
my %newstorehash; |
my %newstorehash; |
foreach (keys %$storehash) { |
foreach my $item (keys(%$storehash)) { |
my $key = $version.':'.&escape($symb).':'.$_; |
my $key = $version.':'.&escape($symb).':'.$item; |
$newstorehash{$key} = $storehash->{$_}; |
$newstorehash{$key} = $storehash->{$item}; |
} |
} |
my $items=''; |
my $items=''; |
my %allitems = (); |
my %allitems = (); |
foreach (keys %newstorehash) { |
foreach my $item (keys(%newstorehash)) { |
if ($_ =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) { |
if ($item =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) { |
my $key = $1.':keys:'.$2; |
my $key = $1.':keys:'.$2; |
$allitems{$key} .= $3.':'; |
$allitems{$key} .= $3.':'; |
} |
} |
$items.=$_.'='.&freeze_escape($newstorehash{$_}).'&'; |
$items.=$item.'='.&freeze_escape($newstorehash{$item}).'&'; |
} |
} |
foreach (keys %allitems) { |
foreach my $item (keys(%allitems)) { |
$allitems{$_} =~ s/\:$//; |
$allitems{$item} =~ s/\:$//; |
$items.= $_.'='.$allitems{$_}.'&'; |
$items.= $item.'='.$allitems{$item}.'&'; |
} |
} |
$items=~s/\&$//; |
$items=~s/\&$//; |
return &reply("put:$udomain:$uname:$namespace:$items",$uhome); |
return &reply("put:$udomain:$uname:$namespace:$items",$uhome); |
Line 3191 sub cput {
|
Line 3333 sub cput {
|
if (!$uname) { $uname=$env{'user.name'}; } |
if (!$uname) { $uname=$env{'user.name'}; } |
my $uhome=&homeserver($uname,$udomain); |
my $uhome=&homeserver($uname,$udomain); |
my $items=''; |
my $items=''; |
foreach (keys %$storehash) { |
foreach my $item (keys(%$storehash)) { |
$items.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&'; |
$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; |
} |
} |
$items=~s/\&$//; |
$items=~s/\&$//; |
return &critical("put:$udomain:$uname:$namespace:$items",$uhome); |
return &critical("put:$udomain:$uname:$namespace:$items",$uhome); |
Line 3203 sub cput {
|
Line 3345 sub cput {
|
sub eget { |
sub eget { |
my ($namespace,$storearr,$udomain,$uname)=@_; |
my ($namespace,$storearr,$udomain,$uname)=@_; |
my $items=''; |
my $items=''; |
foreach (@$storearr) { |
foreach my $item (@$storearr) { |
$items.=escape($_).'&'; |
$items.=&escape($item).'&'; |
} |
} |
$items=~s/\&$//; |
$items=~s/\&$//; |
if (!$udomain) { $udomain=$env{'user.domain'}; } |
if (!$udomain) { $udomain=$env{'user.domain'}; } |
Line 3214 sub eget {
|
Line 3356 sub eget {
|
my @pairs=split(/\&/,$rep); |
my @pairs=split(/\&/,$rep); |
my %returnhash=(); |
my %returnhash=(); |
my $i=0; |
my $i=0; |
foreach (@$storearr) { |
foreach my $item (@$storearr) { |
$returnhash{$_}=&thaw_unescape($pairs[$i]); |
$returnhash{$item}=&thaw_unescape($pairs[$i]); |
$i++; |
$i++; |
} |
} |
return %returnhash; |
return %returnhash; |
Line 3223 sub eget {
|
Line 3365 sub eget {
|
|
|
# ------------------------------------------------------------ tmpput interface |
# ------------------------------------------------------------ tmpput interface |
sub tmpput { |
sub tmpput { |
my ($storehash,$server)=@_; |
my ($storehash,$server,$context)=@_; |
my $items=''; |
my $items=''; |
foreach (keys(%$storehash)) { |
foreach my $item (keys(%$storehash)) { |
$items.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&'; |
$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; |
} |
} |
$items=~s/\&$//; |
$items=~s/\&$//; |
|
if (defined($context)) { |
|
$items .= ':'.&escape($context); |
|
} |
return &reply("tmpput:$items",$server); |
return &reply("tmpput:$items",$server); |
} |
} |
|
|
Line 3258 sub portfolio_access {
|
Line 3403 sub portfolio_access {
|
my ($requrl) = @_; |
my ($requrl) = @_; |
my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl); |
my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl); |
my $result = &get_portfolio_access($udom,$unum,$file_name,$group); |
my $result = &get_portfolio_access($udom,$unum,$file_name,$group); |
|
if ($result) { |
|
my %setters; |
|
if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') { |
|
my ($startblock,$endblock) = |
|
&Apache::loncommon::blockcheck(\%setters,'port',$unum,$udom); |
|
if ($startblock && $endblock) { |
|
return 'B'; |
|
} |
|
} else { |
|
my ($startblock,$endblock) = |
|
&Apache::loncommon::blockcheck(\%setters,'port'); |
|
if ($startblock && $endblock) { |
|
return 'B'; |
|
} |
|
} |
|
} |
if ($result eq 'ok') { |
if ($result eq 'ok') { |
return 'F'; |
return 'F'; |
} elsif ($result =~ /^[^:]+:guest_/) { |
} elsif ($result =~ /^[^:]+:guest_/) { |
Line 3333 sub get_portfolio_access {
|
Line 3494 sub get_portfolio_access {
|
my (%allgroups,%allroles); |
my (%allgroups,%allroles); |
my ($start,$end,$role,$sec,$group); |
my ($start,$end,$role,$sec,$group); |
foreach my $envkey (%env) { |
foreach my $envkey (%env) { |
if ($envkey =~ m-^user\.role\.(gr|cc|in|ta|ep|st)\./([^/]+)/([^/]+)/?([^/]*)$-) { |
if ($envkey =~ m-^user\.role\.(gr|cc|in|ta|ep|st)\./($match_domain)/($match_courseid)/?([^/]*)$-) { |
my $cid = $2.'_'.$3; |
my $cid = $2.'_'.$3; |
if ($1 eq 'gr') { |
if ($1 eq 'gr') { |
$group = $4; |
$group = $4; |
Line 3346 sub get_portfolio_access {
|
Line 3507 sub get_portfolio_access {
|
} |
} |
$allroles{$cid}{$1}{$sec} = $env{$envkey}; |
$allroles{$cid}{$1}{$sec} = $env{$envkey}; |
} |
} |
} elsif ($envkey =~ m-^user\.role\./cr/(\w+/\w+/\w*)./([^/]+)/([^/]+)/?([^/]*)$-) { |
} elsif ($envkey =~ m-^user\.role\./cr/($match_domain/$match_username/\w*)./($match_domain)/($match_courseid)/?([^/]*)$-) { |
my $cid = $2.'_'.$3; |
my $cid = $2.'_'.$3; |
if ($4 eq '') { |
if ($4 eq '') { |
$sec = 'none'; |
$sec = 'none'; |
Line 3441 sub parse_portfolio_url {
|
Line 3602 sub parse_portfolio_url {
|
|
|
my ($type,$udom,$unum,$group,$file_name); |
my ($type,$udom,$unum,$group,$file_name); |
|
|
if ($url =~ m-^/*uploaded/([^/]+)/([^/]+)/portfolio(/.+)$-) { |
if ($url =~ m-^/*(?:uploaded|editupload)/($match_domain)/($match_username)/portfolio(/.+)$-) { |
$type = 1; |
$type = 1; |
$udom = $1; |
$udom = $1; |
$unum = $2; |
$unum = $2; |
$file_name = $3; |
$file_name = $3; |
} elsif ($url =~ m-^/*uploaded/([^/]+)/([^/]+)/groups/([^/]+)/portfolio/(.+)$-) { |
} elsif ($url =~ m-^/*(?:uploaded|editupload)/($match_domain)/($match_courseid)/groups/([^/]+)/portfolio/(.+)$-) { |
$type = 2; |
$type = 2; |
$udom = $1; |
$udom = $1; |
$unum = $2; |
$unum = $2; |
Line 3464 sub is_portfolio_url {
|
Line 3625 sub is_portfolio_url {
|
return scalar(&parse_portfolio_url($url)); |
return scalar(&parse_portfolio_url($url)); |
} |
} |
|
|
|
sub is_portfolio_file { |
|
my ($file) = @_; |
|
if (($file =~ /^portfolio/) || ($file =~ /^groups\/\w+\/portfolio/)) { |
|
return 1; |
|
} |
|
return; |
|
} |
|
|
|
|
# ---------------------------------------------- Custom access rule evaluation |
# ---------------------------------------------- Custom access rule evaluation |
|
|
sub customaccess { |
sub customaccess { |
my ($priv,$uri)=@_; |
my ($priv,$uri)=@_; |
my ($urole,$urealm)=split(/\./,$env{'request.role'}); |
my ($urole,$urealm)=split(/\./,$env{'request.role'},2); |
$urealm=~s/^\W//; |
my (undef,$udom,$ucrs,$usec)=split(/\//,$urealm); |
my ($udom,$ucrs,$usec)=split(/\//,$urealm); |
$udom = &LONCAPA::clean_domain($udom); |
|
$ucrs = &LONCAPA::clean_username($ucrs); |
my $access=0; |
my $access=0; |
foreach (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) { |
foreach my $right (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) { |
my ($effect,$realm,$role)=split(/\:/,$_); |
my ($effect,$realm,$role)=split(/\:/,$right); |
if ($role) { |
if ($role) { |
if ($role ne $urole) { next; } |
if ($role ne $urole) { next; } |
} |
} |
foreach (split(/\s*\,\s*/,$realm)) { |
foreach my $scope (split(/\s*\,\s*/,$realm)) { |
my ($tdom,$tcrs,$tsec)=split(/\_/,$_); |
my ($tdom,$tcrs,$tsec)=split(/\_/,$scope); |
if ($tdom) { |
if ($tdom) { |
if ($tdom ne $udom) { next; } |
if ($tdom ne $udom) { next; } |
} |
} |
Line 3501 sub customaccess {
|
Line 3672 sub customaccess {
|
# ------------------------------------------------- Check for a user privilege |
# ------------------------------------------------- Check for a user privilege |
|
|
sub allowed { |
sub allowed { |
my ($priv,$uri,$symb)=@_; |
my ($priv,$uri,$symb,$role)=@_; |
my $ver_orguri=$uri; |
my $ver_orguri=$uri; |
$uri=&deversion($uri); |
$uri=&deversion($uri); |
my $orguri=$uri; |
my $orguri=$uri; |
$uri=&declutter($uri); |
$uri=&declutter($uri); |
|
|
|
if ($priv eq 'evb') { |
|
# Evade communication block restrictions for specified role in a course |
|
if ($env{'user.priv.'.$role} =~/evb\&([^\:]*)/) { |
|
return $1; |
|
} else { |
|
return; |
|
} |
|
} |
|
|
if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; } |
if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; } |
# Free bre access to adm and meta resources |
# Free bre access to adm and meta resources |
if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard)$})) |
if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard)$})) |
Line 3519 sub allowed {
|
Line 3699 sub allowed {
|
my ($space,$domain,$name,@dir)=split('/',$uri); |
my ($space,$domain,$name,@dir)=split('/',$uri); |
if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) && |
if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) && |
($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) { |
($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) { |
return 'F'; |
my %setters; |
|
my ($startblock,$endblock) = |
|
&Apache::loncommon::blockcheck(\%setters,'port'); |
|
if ($startblock && $endblock) { |
|
return 'B'; |
|
} else { |
|
return 'F'; |
|
} |
} |
} |
|
|
# bre access to group portfolio for rgf priv in group, or mdg or vcg in course. |
# bre access to group portfolio for rgf priv in group, or mdg or vcg in course. |
Line 3690 sub allowed {
|
Line 3877 sub allowed {
|
if ($checkreferer) { |
if ($checkreferer) { |
my $refuri=$env{'httpref.'.$orguri}; |
my $refuri=$env{'httpref.'.$orguri}; |
unless ($refuri) { |
unless ($refuri) { |
foreach (keys %env) { |
foreach my $key (keys(%env)) { |
if ($_=~/^httpref\..*\*/) { |
if ($key=~/^httpref\..*\*/) { |
my $pattern=$_; |
my $pattern=$key; |
$pattern=~s/^httpref\.\/res\///; |
$pattern=~s/^httpref\.\/res\///; |
$pattern=~s/\*/\[\^\/\]\+/g; |
$pattern=~s/\*/\[\^\/\]\+/g; |
$pattern=~s/\//\\\//g; |
$pattern=~s/\//\\\//g; |
if ($orguri=~/$pattern/) { |
if ($orguri=~/$pattern/) { |
$refuri=$env{$_}; |
$refuri=$env{$key}; |
} |
} |
} |
} |
} |
} |
Line 3795 sub allowed {
|
Line 3982 sub allowed {
|
unless ($env{'request.course.id'}) { |
unless ($env{'request.course.id'}) { |
if ($thisallowed eq 'A') { |
if ($thisallowed eq 'A') { |
return 'A'; |
return 'A'; |
|
} elsif ($thisallowed eq 'B') { |
|
return 'B'; |
} else { |
} else { |
return '1'; |
return '1'; |
} |
} |
Line 3862 sub allowed {
|
Line 4051 sub allowed {
|
|
|
if ($thisallowed eq 'A') { |
if ($thisallowed eq 'A') { |
return 'A'; |
return 'A'; |
|
} elsif ($thisallowed eq 'B') { |
|
return 'B'; |
} |
} |
return 'F'; |
return 'F'; |
} |
} |
Line 3915 sub get_symb_from_alias {
|
Line 4106 sub get_symb_from_alias {
|
sub definerole { |
sub definerole { |
if (allowed('mcr','/')) { |
if (allowed('mcr','/')) { |
my ($rolename,$sysrole,$domrole,$courole)=@_; |
my ($rolename,$sysrole,$domrole,$courole)=@_; |
foreach (split(':',$sysrole)) { |
foreach my $role (split(':',$sysrole)) { |
my ($crole,$cqual)=split(/\&/,$_); |
my ($crole,$cqual)=split(/\&/,$role); |
if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; } |
if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; } |
if ($pr{'cr:s'}=~/\Q$crole\E\&/) { |
if ($pr{'cr:s'}=~/\Q$crole\E\&/) { |
if ($pr{'cr:s'}!~/\Q$crole\E\&\w*\Q$cqual\E/) { |
if ($pr{'cr:s'}!~/\Q$crole\E\&\w*\Q$cqual\E/) { |
Line 3924 sub definerole {
|
Line 4115 sub definerole {
|
} |
} |
} |
} |
} |
} |
foreach (split(':',$domrole)) { |
foreach my $role (split(':',$domrole)) { |
my ($crole,$cqual)=split(/\&/,$_); |
my ($crole,$cqual)=split(/\&/,$role); |
if ($pr{'cr:d'}!~/\Q$crole\E/) { return "refused:d:$crole"; } |
if ($pr{'cr:d'}!~/\Q$crole\E/) { return "refused:d:$crole"; } |
if ($pr{'cr:d'}=~/\Q$crole\E\&/) { |
if ($pr{'cr:d'}=~/\Q$crole\E\&/) { |
if ($pr{'cr:d'}!~/\Q$crole\W\&\w*\Q$cqual\E/) { |
if ($pr{'cr:d'}!~/\Q$crole\W\&\w*\Q$cqual\E/) { |
Line 3933 sub definerole {
|
Line 4124 sub definerole {
|
} |
} |
} |
} |
} |
} |
foreach (split(':',$courole)) { |
foreach my $role (split(':',$courole)) { |
my ($crole,$cqual)=split(/\&/,$_); |
my ($crole,$cqual)=split(/\&/,$role); |
if ($pr{'cr:c'}!~/\Q$crole\E/) { return "refused:c:$crole"; } |
if ($pr{'cr:c'}!~/\Q$crole\E/) { return "refused:c:$crole"; } |
if ($pr{'cr:c'}=~/\Q$crole\E\&/) { |
if ($pr{'cr:c'}=~/\Q$crole\E\&/) { |
if ($pr{'cr:c'}!~/\Q$crole\E\&\w*\Q$cqual\E/) { |
if ($pr{'cr:c'}!~/\Q$crole\E\&\w*\Q$cqual\E/) { |
Line 3981 sub log_query {
|
Line 4172 sub log_query {
|
my $uhome=&homeserver($uname,$udom); |
my $uhome=&homeserver($uname,$udom); |
if ($uhome eq 'no_host') { return 'error: no_host'; } |
if ($uhome eq 'no_host') { return 'error: no_host'; } |
my $uhost=$hostname{$uhome}; |
my $uhost=$hostname{$uhome}; |
my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys %filters)); |
my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys(%filters))); |
my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command, |
my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command, |
$uhome); |
$uhome); |
unless ($queryid=~/^\Q$uhost\E\_/) { return 'error: '.$queryid; } |
unless ($queryid=~/^\Q$uhost\E\_/) { return 'error: '.$queryid; } |
return get_query_reply($queryid); |
return get_query_reply($queryid); |
} |
} |
|
|
|
# -------------------------- Update MySQL table for portfolio file |
|
|
|
sub update_portfolio_table { |
|
my ($uname,$udom,$file_name,$query,$group,$action) = @_; |
|
my $homeserver = &homeserver($uname,$udom); |
|
my $queryid= |
|
&reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group). |
|
':'.&escape($file_name).':'.$action,$homeserver); |
|
my $reply = &get_query_reply($queryid); |
|
return $reply; |
|
} |
|
|
# ------- Request retrieval of institutional classlists for course(s) |
# ------- Request retrieval of institutional classlists for course(s) |
|
|
sub fetch_enrollment_query { |
sub fetch_enrollment_query { |
Line 4002 sub fetch_enrollment_query {
|
Line 4205 sub fetch_enrollment_query {
|
} |
} |
my $host=$hostname{$homeserver}; |
my $host=$hostname{$homeserver}; |
my $cmd = ''; |
my $cmd = ''; |
foreach (keys %{$affiliatesref}) { |
foreach my $affiliate (keys %{$affiliatesref}) { |
$cmd .= $_.'='.join(",",@{$$affiliatesref{$_}}).'%%'; |
$cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%'; |
} |
} |
$cmd =~ s/%%$//; |
$cmd =~ s/%%$//; |
$cmd = &escape($cmd); |
$cmd = &escape($cmd); |
Line 4024 sub fetch_enrollment_query {
|
Line 4227 sub fetch_enrollment_query {
|
} else { |
} else { |
my @responses = split/:/,$reply; |
my @responses = split/:/,$reply; |
if ($homeserver eq $perlvar{'lonHostID'}) { |
if ($homeserver eq $perlvar{'lonHostID'}) { |
foreach (@responses) { |
foreach my $line (@responses) { |
my ($key,$value) = split/=/,$_; |
my ($key,$value) = split(/=/,$line,2); |
$$replyref{$key} = $value; |
$$replyref{$key} = $value; |
} |
} |
} else { |
} else { |
my $pathname = $perlvar{'lonDaemons'}.'/tmp'; |
my $pathname = $perlvar{'lonDaemons'}.'/tmp'; |
foreach (@responses) { |
foreach my $line (@responses) { |
my ($key,$value) = split/=/,$_; |
my ($key,$value) = split(/=/,$line); |
$$replyref{$key} = $value; |
$$replyref{$key} = $value; |
if ($value > 0) { |
if ($value > 0) { |
foreach (@{$$affiliatesref{$key}}) { |
foreach my $item (@{$$affiliatesref{$key}}) { |
my $filename = $dom.'_'.$key.'_'.$_.'_classlist.xml'; |
my $filename = $dom.'_'.$key.'_'.$item.'_classlist.xml'; |
my $destname = $pathname.'/'.$filename; |
my $destname = $pathname.'/'.$filename; |
my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver); |
my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver); |
if ($xml_classlist =~ /^error/) { |
if ($xml_classlist =~ /^error/) { |
Line 4194 sub auto_photoupdate {
|
Line 4397 sub auto_photoupdate {
|
my $host=$hostname{$homeserver}; |
my $host=$hostname{$homeserver}; |
my $cmd = ''; |
my $cmd = ''; |
my $maxtries = 1; |
my $maxtries = 1; |
foreach (keys %{$affiliatesref}) { |
foreach my $affiliate (keys(%{$affiliatesref})) { |
$cmd .= $_.'='.join(",",@{$$affiliatesref{$_}}).'%%'; |
$cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%'; |
} |
} |
$cmd =~ s/%%$//; |
$cmd =~ s/%%$//; |
$cmd = &escape($cmd); |
$cmd = &escape($cmd); |
Line 4226 sub auto_photoupdate {
|
Line 4429 sub auto_photoupdate {
|
} |
} |
|
|
sub auto_instcode_format { |
sub auto_instcode_format { |
my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,$cat_order) = @_; |
my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles, |
|
$cat_order) = @_; |
my $courses = ''; |
my $courses = ''; |
my @homeservers; |
my @homeservers; |
if ($caller eq 'global') { |
if ($caller eq 'global') { |
foreach my $tryserver (keys %libserv) { |
foreach my $tryserver (keys(%libserv)) { |
if ($hostdom{$tryserver} eq $codedom) { |
if ($hostdom{$tryserver} eq $codedom) { |
if (!grep/^\Q$tryserver\E$/,@homeservers) { |
if (!grep(/^\Q$tryserver\E$/,@homeservers)) { |
push(@homeservers,$tryserver); |
push(@homeservers,$tryserver); |
} |
} |
} |
} |
Line 4240 sub auto_instcode_format {
|
Line 4444 sub auto_instcode_format {
|
} else { |
} else { |
push(@homeservers,&homeserver($caller,$codedom)); |
push(@homeservers,&homeserver($caller,$codedom)); |
} |
} |
foreach (keys %{$instcodes}) { |
foreach my $code (keys(%{$instcodes})) { |
$courses .= &escape($_).'='.&escape($$instcodes{$_}).'&'; |
$courses .= &escape($code).'='.&escape($$instcodes{$code}).'&'; |
} |
} |
chop($courses); |
chop($courses); |
my $ok_response = 0; |
my $ok_response = 0; |
Line 4251 sub auto_instcode_format {
|
Line 4455 sub auto_instcode_format {
|
$response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server); |
$response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server); |
if ($response !~ /(con_lost|error|no_such_host|refused)/) { |
if ($response !~ /(con_lost|error|no_such_host|refused)/) { |
my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = |
my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = |
split/:/,$response; |
split/:/,$response; |
%{$codes} = (%{$codes},&str2hash($codes_str)); |
%{$codes} = (%{$codes},&str2hash($codes_str)); |
push(@{$codetitles},&str2array($codetitles_str)); |
push(@{$codetitles},&str2array($codetitles_str)); |
%{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str)); |
%{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str)); |
Line 4266 sub auto_instcode_format {
|
Line 4470 sub auto_instcode_format {
|
} |
} |
} |
} |
|
|
|
sub auto_instcode_defaults { |
|
my ($domain,$returnhash,$code_order) = @_; |
|
my @homeservers; |
|
foreach my $tryserver (keys(%libserv)) { |
|
if ($hostdom{$tryserver} eq $domain) { |
|
if (!grep(/^\Q$tryserver\E$/,@homeservers)) { |
|
push(@homeservers,$tryserver); |
|
} |
|
} |
|
} |
|
my $ok_response = 0; |
|
my $response; |
|
while (@homeservers > 0 && $ok_response == 0) { |
|
my $server = shift(@homeservers); |
|
$response=&reply('autoinstcodedefaults:'.$domain,$server); |
|
if ($response !~ /(con_lost|error|no_such_host|refused)/) { |
|
foreach my $pair (split(/\&/,$response)) { |
|
my ($name,$value)=split(/\=/,$pair); |
|
if ($name eq 'code_order') { |
|
@{$code_order} = split(/\&/,&unescape($value)); |
|
} else { |
|
$returnhash->{&unescape($name)}=&unescape($value); |
|
} |
|
} |
|
$ok_response = 1; |
|
} |
|
} |
|
if ($ok_response) { |
|
return 'ok'; |
|
} else { |
|
return $response; |
|
} |
|
} |
|
|
sub auto_validate_class_sec { |
sub auto_validate_class_sec { |
my ($cdom,$cnum,$owner,$inst_class) = @_; |
my ($cdom,$cnum,$owner,$inst_class) = @_; |
my $homeserver = &homeserver($cnum,$cdom); |
my $homeserver = &homeserver($cnum,$cdom); |
Line 4277 sub auto_validate_class_sec {
|
Line 4515 sub auto_validate_class_sec {
|
# ------------------------------------------------------- Course Group routines |
# ------------------------------------------------------- Course Group routines |
|
|
sub get_coursegroups { |
sub get_coursegroups { |
my ($cdom,$cnum,$group) = @_; |
my ($cdom,$cnum,$group,$namespace) = @_; |
return(&dump('coursegroups',$cdom,$cnum,$group)); |
return(&dump($namespace,$cdom,$cnum,$group)); |
} |
} |
|
|
sub modify_coursegroup { |
sub modify_coursegroup { |
Line 4286 sub modify_coursegroup {
|
Line 4524 sub modify_coursegroup {
|
return(&put('coursegroups',$groupsettings,$cdom,$cnum)); |
return(&put('coursegroups',$groupsettings,$cdom,$cnum)); |
} |
} |
|
|
|
sub toggle_coursegroup_status { |
|
my ($cdom,$cnum,$group,$action) = @_; |
|
my ($from_namespace,$to_namespace); |
|
if ($action eq 'delete') { |
|
$from_namespace = 'coursegroups'; |
|
$to_namespace = 'deleted_groups'; |
|
} else { |
|
$from_namespace = 'deleted_groups'; |
|
$to_namespace = 'coursegroups'; |
|
} |
|
my %curr_group = &get_coursegroups($cdom,$cnum,$group,$from_namespace); |
|
if (my $tmp = &error(%curr_group)) { |
|
&Apache::lonnet::logthis('Error retrieving group: '.$tmp.' in '.$cnum.':'.$cdom); |
|
return ('read error',$tmp); |
|
} else { |
|
my %savedsettings = %curr_group; |
|
my $result = &put($to_namespace,\%savedsettings,$cdom,$cnum); |
|
my $deloutcome; |
|
if ($result eq 'ok') { |
|
$deloutcome = &del($from_namespace,[$group],$cdom,$cnum); |
|
} else { |
|
return ('write error',$result); |
|
} |
|
if ($deloutcome eq 'ok') { |
|
return 'ok'; |
|
} else { |
|
return ('delete error',$deloutcome); |
|
} |
|
} |
|
} |
|
|
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) = @_; |
my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id; |
my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id; |
Line 4309 sub get_active_groups {
|
Line 4578 sub get_active_groups {
|
my $now = time; |
my $now = time; |
my %groups = (); |
my %groups = (); |
foreach my $key (keys(%env)) { |
foreach my $key (keys(%env)) { |
if ($key =~ m-user\.role\.gr\./([^/]+)/([^/]+)/(\w+)$-) { |
if ($key =~ m-user\.role\.gr\./($match_domain)/($match_courseid)/(\w+)$-) { |
my ($start,$end) = split(/\./,$env{$key}); |
my ($start,$end) = split(/\./,$env{$key}); |
if (($end!=0) && ($end<$now)) { next; } |
if (($end!=0) && ($end<$now)) { next; } |
if (($start!=0) && ($start>$now)) { next; } |
if (($start!=0) && ($start>$now)) { next; } |
Line 4330 sub get_users_groups {
|
Line 4599 sub get_users_groups {
|
my ($udom,$uname,$courseid) = @_; |
my ($udom,$uname,$courseid) = @_; |
my @usersgroups; |
my @usersgroups; |
my $cachetime=1800; |
my $cachetime=1800; |
$courseid=~s/\_/\//g; |
|
$courseid=~s/^(\w)/\/$1/; |
|
|
|
my $hashid="$udom:$uname:$courseid"; |
my $hashid="$udom:$uname:$courseid"; |
my ($grouplist,$cached)=&is_cached_new('getgroups',$hashid); |
my ($grouplist,$cached)=&is_cached_new('getgroups',$hashid); |
Line 4339 sub get_users_groups {
|
Line 4606 sub get_users_groups {
|
@usersgroups = split(/:/,$grouplist); |
@usersgroups = split(/:/,$grouplist); |
} else { |
} else { |
$grouplist = ''; |
$grouplist = ''; |
my %roleshash = &dump('roles',$udom,$uname,$courseid); |
my $courseurl = &courseid_to_courseurl($courseid); |
my ($tmp) = keys(%roleshash); |
my %roleshash = &dump('roles',$udom,$uname,$courseurl); |
if ($tmp=~/^error:/) { |
my $access_end = $env{'course.'.$courseid. |
&logthis('Error retrieving roles: '.$tmp.' for '.$uname.':'.$udom); |
'.default_enrollment_end_date'}; |
} else { |
my $now = time; |
my $access_end = $env{'course.'.$courseid. |
foreach my $key (keys(%roleshash)) { |
'.default_enrollment_end_date'}; |
if ($key =~ /^\Q$courseurl\E\/(\w+)\_gr$/) { |
my $now = time; |
my $group = $1; |
foreach my $key (keys(%roleshash)) { |
if ($roleshash{$key} =~ /_(\d+)_(\d+)$/) { |
if ($key =~ /^\Q$courseid\E\/(\w+)\_gr$/) { |
my $start = $2; |
my $group = $1; |
my $end = $1; |
if ($roleshash{$key} =~ /_(\d+)_(\d+)$/) { |
if ($start == -1) { next; } # deleted from group |
my $start = $2; |
if (($start!=0) && ($start>$now)) { next; } |
my $end = $1; |
if (($end!=0) && ($end<$now)) { |
if ($start == -1) { next; } # deleted from group |
if ($access_end && $access_end < $now) { |
if (($start!=0) && ($start>$now)) { next; } |
if ($access_end - $end < 86400) { |
if (($end!=0) && ($end<$now)) { |
push(@usersgroups,$group); |
if ($access_end && $access_end < $now) { |
|
if ($access_end - $end < 86400) { |
|
push(@usersgroups,$group); |
|
} |
|
} |
} |
next; |
|
} |
} |
push(@usersgroups,$group); |
next; |
} |
} |
|
push(@usersgroups,$group); |
} |
} |
} |
} |
@usersgroups = &sort_course_groups($courseid,@usersgroups); |
|
$grouplist = join(':',@usersgroups); |
|
&do_cache_new('getgroups',$hashid,$grouplist,$cachetime); |
|
} |
} |
|
@usersgroups = &sort_course_groups($courseid,@usersgroups); |
|
$grouplist = join(':',@usersgroups); |
|
&do_cache_new('getgroups',$hashid,$grouplist,$cachetime); |
} |
} |
return @usersgroups; |
return @usersgroups; |
} |
} |
Line 4378 sub get_users_groups {
|
Line 4641 sub get_users_groups {
|
sub devalidate_getgroups_cache { |
sub devalidate_getgroups_cache { |
my ($udom,$uname,$cdom,$cnum)=@_; |
my ($udom,$uname,$cdom,$cnum)=@_; |
my $courseid = $cdom.'_'.$cnum; |
my $courseid = $cdom.'_'.$cnum; |
$courseid=~s/\_/\//g; |
|
$courseid=~s/^(\w)/\/$1/; |
|
my $hashid="$udom:$uname:$courseid"; |
my $hashid="$udom:$uname:$courseid"; |
&devalidate_cache_new('getgroups',$hashid); |
&devalidate_cache_new('getgroups',$hashid); |
} |
} |
Line 4418 sub assignrole {
|
Line 4680 sub assignrole {
|
my $mrole; |
my $mrole; |
if ($role =~ /^cr\//) { |
if ($role =~ /^cr\//) { |
my $cwosec=$url; |
my $cwosec=$url; |
$cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/; |
$cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/; |
unless (&allowed('ccr',$cwosec)) { |
unless (&allowed('ccr',$cwosec)) { |
&logthis('Refused custom assignrole: '. |
&logthis('Refused custom assignrole: '. |
$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. |
$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. |
Line 4428 sub assignrole {
|
Line 4690 sub assignrole {
|
$mrole='cr'; |
$mrole='cr'; |
} elsif ($role =~ /^gr\//) { |
} elsif ($role =~ /^gr\//) { |
my $cwogrp=$url; |
my $cwogrp=$url; |
$cwogrp=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/; |
$cwogrp=~s{^/($match_domain)/($match_courseid)/.*}{$1/$2}; |
unless (&allowed('mdg',$cwogrp)) { |
unless (&allowed('mdg',$cwogrp)) { |
&logthis('Refused group assignrole: '. |
&logthis('Refused group assignrole: '. |
$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. |
$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. |
Line 4438 sub assignrole {
|
Line 4700 sub assignrole {
|
$mrole='gr'; |
$mrole='gr'; |
} else { |
} else { |
my $cwosec=$url; |
my $cwosec=$url; |
$cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/; |
$cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/; |
unless ((&allowed('c'.$role,$cwosec)) || &allowed('c'.$role,$udom)) { |
unless ((&allowed('c'.$role,$cwosec)) || &allowed('c'.$role,$udom)) { |
&logthis('Refused assignrole: '. |
&logthis('Refused assignrole: '. |
$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. |
$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. |
Line 4518 sub modifyuser {
|
Line 4780 sub modifyuser {
|
$umode, $upass, $first, |
$umode, $upass, $first, |
$middle, $last, $gene, |
$middle, $last, $gene, |
$forceid, $desiredhome, $email)=@_; |
$forceid, $desiredhome, $email)=@_; |
$udom=~s/\W//g; |
$udom= &LONCAPA::clean_domain($udom); |
$uname=~s/\W//g; |
$uname=&LONCAPA::clean_username($uname); |
&logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. |
&logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. |
$umode.', '.$first.', '.$middle.', '. |
$umode.', '.$first.', '.$middle.', '. |
$last.', '.$gene.'(forceid: '.$forceid.')'. |
$last.', '.$gene.'(forceid: '.$forceid.')'. |
Line 4668 sub modify_student_enrollment {
|
Line 4930 sub modify_student_enrollment {
|
['firstname','middlename','lastname', 'generation','id'] |
['firstname','middlename','lastname', 'generation','id'] |
,$udom,$uname); |
,$udom,$uname); |
|
|
#foreach (keys(%tmp)) { |
#foreach my $key (keys(%tmp)) { |
# &logthis("key $_ = ".$tmp{$_}); |
# &logthis("key $key = ".$tmp{$key}); |
#} |
#} |
$first = $tmp{'firstname'} if (!defined($first) || $first eq ''); |
$first = $tmp{'firstname'} if (!defined($first) || $first eq ''); |
$middle = $tmp{'middlename'} if (!defined($middle) || $middle eq ''); |
$middle = $tmp{'middlename'} if (!defined($middle) || $middle eq ''); |
Line 4727 sub writecoursepref {
|
Line 4989 sub writecoursepref {
|
return 'error: no such course'; |
return 'error: no such course'; |
} |
} |
my $cstring=''; |
my $cstring=''; |
foreach (keys %prefs) { |
foreach my $pref (keys(%prefs)) { |
$cstring.=escape($_).'='.escape($prefs{$_}).'&'; |
$cstring.=&escape($pref).'='.&escape($prefs{$pref}).'&'; |
} |
} |
$cstring=~s/\&$//; |
$cstring=~s/\&$//; |
return reply('put:'.$cdomain.':'.$cnum.':environment:'.$cstring,$chome); |
return reply('put:'.$cdomain.':'.$cnum.':environment:'.$cstring,$chome); |
Line 4804 ENDINITMAP
|
Line 5066 ENDINITMAP
|
return '/'.$udom.'/'.$uname; |
return '/'.$udom.'/'.$uname; |
} |
} |
|
|
|
sub is_course { |
|
my ($cdom,$cnum) = @_; |
|
my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef, |
|
undef,'.'); |
|
if (exists($courses{$cdom.'_'.$cnum})) { |
|
return 1; |
|
} |
|
return 0; |
|
} |
|
|
# ---------------------------------------------------------- Assign Custom Role |
# ---------------------------------------------------------- Assign Custom Role |
|
|
sub assigncustomrole { |
sub assigncustomrole { |
Line 4862 sub is_locked {
|
Line 5134 sub is_locked {
|
|
|
sub declutter_portfile { |
sub declutter_portfile { |
my ($file) = @_; |
my ($file) = @_; |
&logthis("got $file"); |
$file =~ s{^(/portfolio/|portfolio/)}{/}; |
$file =~ s-^(/portfolio/|portfolio/)-/-; |
|
&logthis("ret $file"); |
|
return $file; |
return $file; |
} |
} |
|
|
Line 4935 sub files_not_in_path {
|
Line 5205 sub files_not_in_path {
|
my $filename = $user."savedfiles"; |
my $filename = $user."savedfiles"; |
my @return_files; |
my @return_files; |
my $path_part; |
my $path_part; |
open (IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); |
open(IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); |
while (<IN>) { |
while (my $line = <IN>) { |
#ok, I know it's clunky, but I want it to work |
#ok, I know it's clunky, but I want it to work |
my @paths_and_file = split m!/!, $_; |
my @paths_and_file = split(m|/|, $line); |
my $file_part = pop (@paths_and_file); |
my $file_part = pop(@paths_and_file); |
chomp ($file_part); |
chomp($file_part); |
my $path_part = join ('/', @paths_and_file); |
my $path_part = join('/', @paths_and_file); |
$path_part .= '/'; |
$path_part .= '/'; |
my $path_and_file = $path_part.$file_part; |
my $path_and_file = $path_part.$file_part; |
if ($path_part ne $path) { |
if ($path_part ne $path) { |
push (@return_files, ($path_and_file)); |
push(@return_files, ($path_and_file)); |
} |
} |
} |
} |
close (OUT); |
close(OUT); |
return (@return_files); |
return (@return_files); |
} |
} |
|
|
Line 5011 sub modify_access_controls {
|
Line 5281 sub modify_access_controls {
|
for (my $i=0; $i<$numnew; $i++) { |
for (my $i=0; $i<$numnew; $i++) { |
my $newkey = $newitems[$i]; |
my $newkey = $newitems[$i]; |
my $newid = &Apache::loncommon::get_cgi_id(); |
my $newid = &Apache::loncommon::get_cgi_id(); |
$newkey =~ s/^(\d+)/$newid/; |
if ($newkey =~ /^\d+:/) { |
$translation{$1} = $newid; |
$newkey =~ s/^(\d+)/$newid/; |
|
$translation{$1} = $newid; |
|
} elsif ($newkey =~ /^\d+_\d+_\d+:/) { |
|
$newkey =~ s/^(\d+_\d+_\d+)/$newid/; |
|
$translation{$1} = $newid; |
|
} |
$new_values{$file_name."\0".$newkey} = |
$new_values{$file_name."\0".$newkey} = |
$$changes{'activate'}{$newitems[$i]}; |
$$changes{'activate'}{$newitems[$i]}; |
$new_control{$newkey} = $now; |
$new_control{$newkey} = $now; |
Line 5077 sub modify_access_controls {
|
Line 5352 sub modify_access_controls {
|
# 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 = |
|
&update_portfolio_table($user,$domain,$file,'portfolio_access', |
|
$group); |
} else { |
} else { |
$outcome = "error: could not obtain lockfile\n"; |
$outcome = "error: could not obtain lockfile\n"; |
} |
} |
return ($outcome,$deloutcome,\%new_values,\%translation); |
return ($outcome,$deloutcome,\%new_values,\%translation); |
} |
} |
|
|
|
sub make_public_indefinitely { |
|
my ($requrl) = @_; |
|
my $now = time; |
|
my $action = 'activate'; |
|
my $aclnum = 0; |
|
if (&is_portfolio_url($requrl)) { |
|
my (undef,$udom,$unum,$file_name,$group) = |
|
&parse_portfolio_url($requrl); |
|
my $current_perms = &get_portfile_permissions($udom,$unum); |
|
my %access_controls = &get_access_controls($current_perms, |
|
$group,$file_name); |
|
foreach my $key (keys(%{$access_controls{$file_name}})) { |
|
my ($num,$scope,$end,$start) = |
|
($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/); |
|
if ($scope eq 'public') { |
|
if ($start <= $now && $end == 0) { |
|
$action = 'none'; |
|
} else { |
|
$action = 'update'; |
|
$aclnum = $num; |
|
} |
|
last; |
|
} |
|
} |
|
if ($action eq 'none') { |
|
return 'ok'; |
|
} else { |
|
my %changes; |
|
my $newend = 0; |
|
my $newstart = $now; |
|
my $newkey = $aclnum.':public_'.$newend.'_'.$newstart; |
|
$changes{$action}{$newkey} = { |
|
type => 'public', |
|
time => { |
|
start => $newstart, |
|
end => $newend, |
|
}, |
|
}; |
|
my ($outcome,$deloutcome,$new_values,$translation) = |
|
&modify_access_controls($file_name,\%changes,$udom,$unum); |
|
return $outcome; |
|
} |
|
} else { |
|
return 'invalid'; |
|
} |
|
} |
|
|
#------------------------------------------------------Get Marked as Read Only |
#------------------------------------------------------Get Marked as Read Only |
|
|
sub get_marked_as_readonly { |
sub get_marked_as_readonly { |
Line 5212 sub dirlist {
|
Line 5543 sub dirlist {
|
|
|
if($udom) { |
if($udom) { |
if($uname) { |
if($uname) { |
my $listing=reply('ls2:'.$dirRoot.'/'.$uri, |
my $listing = &reply('ls2:'.$dirRoot.'/'.$uri, |
homeserver($uname,$udom)); |
&homeserver($uname,$udom)); |
my @listing_results; |
my @listing_results; |
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)); |
@listing_results = split(/:/,$listing); |
@listing_results = split(/:/,$listing); |
} else { |
} else { |
@listing_results = map { &unescape($_); } split(/:/,$listing); |
@listing_results = map { &unescape($_); } split(/:/,$listing); |
} |
} |
return @listing_results; |
return @listing_results; |
} elsif(!defined($alternateDirectoryRoot)) { |
} elsif(!defined($alternateDirectoryRoot)) { |
my $tryserver; |
my %allusers; |
my %allusers=(); |
foreach my $tryserver (keys(%libserv)) { |
foreach $tryserver (keys %libserv) { |
|
if($hostdom{$tryserver} eq $udom) { |
if($hostdom{$tryserver} eq $udom) { |
my $listing=reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'. |
my $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'. |
$udom, $tryserver); |
$udom, $tryserver); |
my @listing_results; |
my @listing_results; |
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); |
@listing_results = split(/:/,$listing); |
@listing_results = split(/:/,$listing); |
} else { |
} else { |
@listing_results = |
@listing_results = |
Line 5242 sub dirlist {
|
Line 5572 sub dirlist {
|
if ($listing_results[0] ne 'no_such_dir' && |
if ($listing_results[0] ne 'no_such_dir' && |
$listing_results[0] ne 'empty' && |
$listing_results[0] ne 'empty' && |
$listing_results[0] ne 'con_lost') { |
$listing_results[0] ne 'con_lost') { |
foreach (@listing_results) { |
foreach my $line (@listing_results) { |
my ($entry,@stat)=split(/&/,$_); |
my ($entry) = split(/&/,$line,2); |
$allusers{$entry}=1; |
$allusers{$entry} = 1; |
} |
} |
} |
} |
} |
} |
} |
} |
my $alluserstr=''; |
my $alluserstr=''; |
foreach (sort keys %allusers) { |
foreach my $user (sort(keys(%allusers))) { |
$alluserstr.=$_.'&user:'; |
$alluserstr.=$user.'&user:'; |
} |
} |
$alluserstr=~s/:$//; |
$alluserstr=~s/:$//; |
return split(/:/,$alluserstr); |
return split(/:/,$alluserstr); |
} else { |
} else { |
my @emptyResults = (); |
return ('missing user name'); |
push(@emptyResults, 'missing user name'); |
|
return split(':',@emptyResults); |
|
} |
} |
} elsif(!defined($alternateDirectoryRoot)) { |
} elsif(!defined($alternateDirectoryRoot)) { |
my $tryserver; |
my $tryserver; |
my %alldom=(); |
my %alldom=(); |
foreach $tryserver (keys %libserv) { |
foreach $tryserver (keys(%libserv)) { |
$alldom{$hostdom{$tryserver}}=1; |
$alldom{$hostdom{$tryserver}}=1; |
} |
} |
my $alldomstr=''; |
my $alldomstr=''; |
foreach (sort keys %alldom) { |
foreach my $domain (sort(keys(%alldom))) { |
$alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'/&domain:'; |
$alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain:'; |
} |
} |
$alldomstr=~s/:$//; |
$alldomstr=~s/:$//; |
return split(/:/,$alldomstr); |
return split(/:/,$alldomstr); |
} else { |
} else { |
my @emptyResults = (); |
return ('missing domain'); |
push(@emptyResults, 'missing domain'); |
|
return split(':',@emptyResults); |
|
} |
} |
} |
} |
|
|
Line 5293 sub dirlist {
|
Line 5619 sub dirlist {
|
## |
## |
sub GetFileTimestamp { |
sub GetFileTimestamp { |
my ($studentDomain,$studentName,$filename,$root)=@_; |
my ($studentDomain,$studentName,$filename,$root)=@_; |
$studentDomain=~s/\W//g; |
$studentDomain = &LONCAPA::clean_domain($studentDomain); |
$studentName=~s/\W//g; |
$studentName = &LONCAPA::clean_username($studentName); |
my $subdir=$studentName.'__'; |
my $subdir=$studentName.'__'; |
$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; |
$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; |
my $proname="$studentDomain/$subdir/$studentName"; |
my $proname="$studentDomain/$subdir/$studentName"; |
Line 5312 sub GetFileTimestamp {
|
Line 5638 sub GetFileTimestamp {
|
|
|
sub stat_file { |
sub stat_file { |
my ($uri) = @_; |
my ($uri) = @_; |
$uri = &clutter($uri); |
$uri = &clutter_with_no_wrapper($uri); |
|
|
# we want just the url part without the unneeded accessor url bits |
|
if ($uri =~ m-^/adm/-) { |
|
$uri=~s-^/adm/wrapper/-/-; |
|
$uri=~s-^/adm/coursedocs/showdoc/-/-; |
|
} |
|
my ($udom,$uname,$file,$dir); |
my ($udom,$uname,$file,$dir); |
if ($uri =~ m-^/(uploaded|editupload)/-) { |
if ($uri =~ m-^/(uploaded|editupload)/-) { |
($udom,$uname,$file) = |
($udom,$uname,$file) = |
($uri =~ m-/(?:uploaded|editupload)/?([^/]*)/?([^/]*)/?(.*)-); |
($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_name)/?(.*)-); |
$file = 'userfiles/'.$file; |
$file = 'userfiles/'.$file; |
$dir = &propath($udom,$uname); |
$dir = &propath($udom,$uname); |
} |
} |
if ($uri =~ m-^/res/-) { |
if ($uri =~ m-^/res/-) { |
($udom,$uname) = |
($udom,$uname) = |
($uri =~ m-/(?:res)/?([^/]*)/?([^/]*)/-); |
($uri =~ m-/(?:res)/?($match_domain)/?($match_username)/-); |
$file = $uri; |
$file = $uri; |
} |
} |
|
|
Line 5550 sub EXT {
|
Line 5871 sub EXT {
|
$symbparm=&get_symb_from_alias($symbparm); |
$symbparm=&get_symb_from_alias($symbparm); |
} |
} |
if (!($uname && $udom)) { |
if (!($uname && $udom)) { |
(my $cursymb,$courseid,$udom,$uname,$publicuser)= |
(my $cursymb,$courseid,$udom,$uname,$publicuser)= &whichuser($symbparm); |
&Apache::lonxml::whichuser($symbparm); |
|
if (!$symbparm) { $symbparm=$cursymb; } |
if (!$symbparm) { $symbparm=$cursymb; } |
} else { |
} else { |
$courseid=$env{'request.course.id'}; |
$courseid=$env{'request.course.id'}; |
Line 5910 sub metadata {
|
Line 6230 sub metadata {
|
(($uri =~ m|^/*adm/|) && |
(($uri =~ m|^/*adm/|) && |
($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) || |
($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) || |
($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) || |
($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) || |
($uri =~ m|home/[^/]+/public_html/|)) { |
($uri =~ m|home/$match_username/public_html/|)) { |
return undef; |
return undef; |
} |
} |
my $filename=$uri; |
my $filename=$uri; |
Line 6205 sub gettitle {
|
Line 6525 sub gettitle {
|
sub get_slot { |
sub get_slot { |
my ($which,$cnum,$cdom)=@_; |
my ($which,$cnum,$cdom)=@_; |
if (!$cnum || !$cdom) { |
if (!$cnum || !$cdom) { |
(undef,my $courseid)=&Apache::lonxml::whichuser(); |
(undef,my $courseid)=&whichuser(); |
$cdom=$env{'course.'.$courseid.'.domain'}; |
$cdom=$env{'course.'.$courseid.'.domain'}; |
$cnum=$env{'course.'.$courseid.'.num'}; |
$cnum=$env{'course.'.$courseid.'.num'}; |
} |
} |
Line 6254 sub symblist {
|
Line 6574 sub symblist {
|
sub symbverify { |
sub symbverify { |
my ($symb,$thisurl)=@_; |
my ($symb,$thisurl)=@_; |
my $thisfn=$thisurl; |
my $thisfn=$thisurl; |
# wrapper not part of symbs |
|
$thisfn=~s/^\/adm\/wrapper//; |
|
$thisfn=~s/^\/adm\/coursedocs\/showdoc\///; |
|
$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 |
if ($thisfn=~/\.(page|sequence)$/) { return 1; } |
if ($thisfn=~/\.(page|sequence)$/) { return 1; } |
Line 6280 sub symbverify {
|
Line 6597 sub symbverify {
|
} |
} |
if ($ids) { |
if ($ids) { |
# ------------------------------------------------------------------- Has ID(s) |
# ------------------------------------------------------------------- Has ID(s) |
foreach (split(/\,/,$ids)) { |
foreach my $id (split(/\,/,$ids)) { |
my ($mapid,$resid)=split(/\./,$_); |
my ($mapid,$resid)=split(/\./,$id); |
if ( |
if ( |
&symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn) |
&symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn) |
eq $symb) { |
eq $symb) { |
if (($env{'request.role.adv'}) || |
if (($env{'request.role.adv'}) || |
$bighash{'encrypted_'.$_} eq $env{'request.enc'}) { |
$bighash{'encrypted_'.$id} eq $env{'request.enc'}) { |
$okay=1; |
$okay=1; |
} |
} |
} |
} |
Line 6429 sub symbread {
|
Line 6746 sub symbread {
|
} elsif (!$donotrecurse) { |
} elsif (!$donotrecurse) { |
# ------------------------------------------ There is more than one possibility |
# ------------------------------------------ There is more than one possibility |
my $realpossible=0; |
my $realpossible=0; |
foreach (@possibilities) { |
foreach my $id (@possibilities) { |
my $file=$bighash{'src_'.$_}; |
my $file=$bighash{'src_'.$id}; |
if (&allowed('bre',$file)) { |
if (&allowed('bre',$file)) { |
my ($mapid,$resid)=split(/\./,$_); |
my ($mapid,$resid)=split(/\./,$id); |
if ($bighash{'map_type_'.$mapid} ne 'page') { |
if ($bighash{'map_type_'.$mapid} ne 'page') { |
$realpossible++; |
$realpossible++; |
$syval=&encode_symb($bighash{'map_id_'.$mapid}, |
$syval=&encode_symb($bighash{'map_id_'.$mapid}, |
Line 6539 sub latest_rnd_algorithm_id {
|
Line 6856 sub latest_rnd_algorithm_id {
|
|
|
sub get_rand_alg { |
sub get_rand_alg { |
my ($courseid)=@_; |
my ($courseid)=@_; |
if (!$courseid) { $courseid=(&Apache::lonxml::whichuser())[1]; } |
if (!$courseid) { $courseid=(&whichuser())[1]; } |
if ($courseid) { |
if ($courseid) { |
return $env{"course.$courseid.rndseed"}; |
return $env{"course.$courseid.rndseed"}; |
} |
} |
Line 6565 sub getCODE {
|
Line 6882 sub getCODE {
|
sub rndseed { |
sub rndseed { |
my ($symb,$courseid,$domain,$username)=@_; |
my ($symb,$courseid,$domain,$username)=@_; |
|
|
my ($wsymb,$wcourseid,$wdomain,$wusername)=&Apache::lonxml::whichuser(); |
my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser(); |
if (!$symb) { |
if (!$symb) { |
unless ($symb=$wsymb) { return time; } |
unless ($symb=$wsymb) { return time; } |
} |
} |
Line 6573 sub rndseed {
|
Line 6890 sub rndseed {
|
if (!$domain) { $domain=$wdomain; } |
if (!$domain) { $domain=$wdomain; } |
if (!$username) { $username=$wusername } |
if (!$username) { $username=$wusername } |
my $which=&get_rand_alg(); |
my $which=&get_rand_alg(); |
|
|
if (defined(&getCODE())) { |
if (defined(&getCODE())) { |
if ($which eq '64bit5') { |
if ($which eq '64bit5') { |
return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username); |
return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username); |
Line 6606 sub rndseed_32bit {
|
Line 6924 sub rndseed_32bit {
|
my $domainseed=unpack("%32C*",$domain) << 7; |
my $domainseed=unpack("%32C*",$domain) << 7; |
my $courseseed=unpack("%32C*",$courseid); |
my $courseseed=unpack("%32C*",$courseid); |
my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck; |
my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck; |
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
#&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
#&Apache::lonxml::debug("rndseed :$num:$symb"); |
#&logthis("rndseed :$num:$symb"); |
if ($_64bit) { $num=(($num<<32)>>32); } |
if ($_64bit) { $num=(($num<<32)>>32); } |
return $num; |
return $num; |
} |
} |
Line 6627 sub rndseed_64bit {
|
Line 6945 sub rndseed_64bit {
|
|
|
my $num1=$symbchck+$symbseed+$namechck; |
my $num1=$symbchck+$symbseed+$namechck; |
my $num2=$nameseed+$domainseed+$courseseed; |
my $num2=$nameseed+$domainseed+$courseseed; |
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
#&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
#&Apache::lonxml::debug("rndseed :$num:$symb"); |
#&logthis("rndseed :$num:$symb"); |
if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } |
|
if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } |
if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } |
return "$num1,$num2"; |
return "$num1,$num2"; |
} |
} |
Line 6651 sub rndseed_64bit2 {
|
Line 6968 sub rndseed_64bit2 {
|
|
|
my $num1=$symbchck+$symbseed+$namechck; |
my $num1=$symbchck+$symbseed+$namechck; |
my $num2=$nameseed+$domainseed+$courseseed; |
my $num2=$nameseed+$domainseed+$courseseed; |
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
#&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
#&Apache::lonxml::debug("rndseed :$num:$symb"); |
#&logthis("rndseed :$num:$symb"); |
|
if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } |
return "$num1,$num2"; |
return "$num1,$num2"; |
} |
} |
} |
} |
Line 6673 sub rndseed_64bit3 {
|
Line 6991 sub rndseed_64bit3 {
|
|
|
my $num1=$symbchck+$symbseed+$namechck; |
my $num1=$symbchck+$symbseed+$namechck; |
my $num2=$nameseed+$domainseed+$courseseed; |
my $num2=$nameseed+$domainseed+$courseseed; |
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
#&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
#&Apache::lonxml::debug("rndseed :$num1:$num2:$_64bit"); |
#&logthis("rndseed :$num1:$num2:$_64bit"); |
if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } |
if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } |
|
|
return "$num1:$num2"; |
return "$num1:$num2"; |
Line 6697 sub rndseed_64bit4 {
|
Line 7015 sub rndseed_64bit4 {
|
|
|
my $num1=$symbchck+$symbseed+$namechck; |
my $num1=$symbchck+$symbseed+$namechck; |
my $num2=$nameseed+$domainseed+$courseseed; |
my $num2=$nameseed+$domainseed+$courseseed; |
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
#&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
#&Apache::lonxml::debug("rndseed :$num1:$num2:$_64bit"); |
#&logthis("rndseed :$num1:$num2:$_64bit"); |
if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } |
if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } |
|
|
return "$num1:$num2"; |
return "$num1:$num2"; |
Line 6722 sub rndseed_CODE_64bit {
|
Line 7040 sub rndseed_CODE_64bit {
|
my $courseseed=unpack("%32S*",$courseid.' '); |
my $courseseed=unpack("%32S*",$courseid.' '); |
my $num1=$symbseed+$CODEchck; |
my $num1=$symbseed+$CODEchck; |
my $num2=$CODEseed+$courseseed+$symbchck; |
my $num2=$CODEseed+$courseseed+$symbchck; |
#&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck"); |
#&logthis("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck"); |
#&Apache::lonxml::debug("rndseed :$num1:$num2:$symb"); |
#&logthis("rndseed :$num1:$num2:$symb"); |
if ($_64bit) { $num1=(($num1<<32)>>32); } |
if ($_64bit) { $num1=(($num1<<32)>>32); } |
if ($_64bit) { $num2=(($num2<<32)>>32); } |
if ($_64bit) { $num2=(($num2<<32)>>32); } |
return "$num1:$num2"; |
return "$num1:$num2"; |
Line 6741 sub rndseed_CODE_64bit4 {
|
Line 7059 sub rndseed_CODE_64bit4 {
|
my $courseseed=unpack("%32S*",$courseid.' '); |
my $courseseed=unpack("%32S*",$courseid.' '); |
my $num1=$symbseed+$CODEchck; |
my $num1=$symbseed+$CODEchck; |
my $num2=$CODEseed+$courseseed+$symbchck; |
my $num2=$CODEseed+$courseseed+$symbchck; |
#&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck"); |
#&logthis("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck"); |
#&Apache::lonxml::debug("rndseed :$num1:$num2:$symb"); |
#&logthis("rndseed :$num1:$num2:$symb"); |
if ($_64bit) { $num1=(($num1<<32)>>32); } |
if ($_64bit) { $num1=(($num1<<32)>>32); } |
if ($_64bit) { $num2=(($num2<<32)>>32); } |
if ($_64bit) { $num2=(($num2<<32)>>32); } |
return "$num1:$num2"; |
return "$num1:$num2"; |
Line 6803 sub ireceipt {
|
Line 7121 sub ireceipt {
|
my $return =&recprefix($fucourseid).'-'; |
my $return =&recprefix($fucourseid).'-'; |
if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' || |
if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' || |
$env{'request.state'} eq 'construct') { |
$env{'request.state'} eq 'construct') { |
&Apache::lonxml::debug("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname). |
#&logthis("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname)." and ".($cpart%$cudom)); |
" and ".($cpart%$cudom)); |
|
|
|
$return.= ($cunique%$cuname+ |
$return.= ($cunique%$cuname+ |
$cunique%$cudom+ |
$cunique%$cudom+ |
Line 6827 sub ireceipt {
|
Line 7144 sub ireceipt {
|
|
|
sub receipt { |
sub receipt { |
my ($part)=@_; |
my ($part)=@_; |
my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser(); |
my ($symb,$courseid,$domain,$name) = &whichuser(); |
return &ireceipt($name,$domain,$courseid,$symb,$part); |
return &ireceipt($name,$domain,$courseid,$symb,$part); |
} |
} |
|
|
|
sub whichuser { |
|
my ($passedsymb)=@_; |
|
my ($symb,$courseid,$domain,$name,$publicuser); |
|
if (defined($env{'form.grade_symb'})) { |
|
my ($tmp_courseid)=&get_env_multiple('form.grade_courseid'); |
|
my $allowed=&allowed('vgr',$tmp_courseid); |
|
if (!$allowed && |
|
exists($env{'request.course.sec'}) && |
|
$env{'request.course.sec'} !~ /^\s*$/) { |
|
$allowed=&allowed('vgr',$tmp_courseid. |
|
'/'.$env{'request.course.sec'}); |
|
} |
|
if ($allowed) { |
|
($symb)=&get_env_multiple('form.grade_symb'); |
|
$courseid=$tmp_courseid; |
|
($domain)=&get_env_multiple('form.grade_domain'); |
|
($name)=&get_env_multiple('form.grade_username'); |
|
return ($symb,$courseid,$domain,$name,$publicuser); |
|
} |
|
} |
|
if (!$passedsymb) { |
|
$symb=&symbread(); |
|
} else { |
|
$symb=$passedsymb; |
|
} |
|
$courseid=$env{'request.course.id'}; |
|
$domain=$env{'user.domain'}; |
|
$name=$env{'user.name'}; |
|
if ($name eq 'public' && $domain eq 'public') { |
|
if (!defined($env{'form.username'})) { |
|
$env{'form.username'}.=time.rand(10000000); |
|
} |
|
$name.=$env{'form.username'}; |
|
} |
|
return ($symb,$courseid,$domain,$name,$publicuser); |
|
|
|
} |
|
|
# ------------------------------------------------------------ Serves up a file |
# ------------------------------------------------------------ Serves up a file |
# returns either the contents of the file or |
# returns either the contents of the file or |
# -1 if the file doesn't exist |
# -1 if the file doesn't exist |
Line 6853 sub repcopy_userfile {
|
Line 7208 sub repcopy_userfile {
|
if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); } |
if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); } |
if ($file =~ m|^/home/httpd/html/lonUsers/|) { return 'ok'; } |
if ($file =~ m|^/home/httpd/html/lonUsers/|) { return 'ok'; } |
my ($cdom,$cnum,$filename) = |
my ($cdom,$cnum,$filename) = |
($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+([^/]+)/+([^/]+)/+(.*)|); |
($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)|); |
my ($info,$rtncode); |
|
my $uri="/uploaded/$cdom/$cnum/$filename"; |
my $uri="/uploaded/$cdom/$cnum/$filename"; |
if (-e "$file") { |
if (-e "$file") { |
|
# we already have a local copy, check it out |
my @fileinfo = stat($file); |
my @fileinfo = stat($file); |
|
my $rtncode; |
|
my $info; |
my $lwpresp = &getuploaded('HEAD',$uri,$cdom,$cnum,\$info,\$rtncode); |
my $lwpresp = &getuploaded('HEAD',$uri,$cdom,$cnum,\$info,\$rtncode); |
if ($lwpresp ne 'ok') { |
if ($lwpresp ne 'ok') { |
|
# there is no such file anymore, even though we had a local copy |
if ($rtncode eq '404') { |
if ($rtncode eq '404') { |
unlink($file); |
unlink($file); |
} |
} |
#my $ua=new LWP::UserAgent; |
|
#my $request=new HTTP::Request('GET',&tokenwrapper($uri)); |
|
#my $response=$ua->request($request); |
|
#if ($response->is_success()) { |
|
# return $response->content; |
|
# } else { |
|
# return -1; |
|
# } |
|
return -1; |
return -1; |
} |
} |
if ($info < $fileinfo[9]) { |
if ($info < $fileinfo[9]) { |
|
# nice, the file we have is up-to-date, just say okay |
return 'ok'; |
return 'ok'; |
|
} else { |
|
# the file is outdated, get rid of it |
|
unlink($file); |
} |
} |
$info = ''; |
} |
$lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode); |
# one way or the other, at this point, we don't have the file |
if ($lwpresp ne 'ok') { |
# construct the correct path for the file |
return -1; |
my @parts = ($cdom,$cnum); |
} |
if ($filename =~ m|^(.+)/[^/]+$|) { |
} else { |
push @parts, split(/\//,$1); |
my $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode); |
} |
if ($lwpresp ne 'ok') { |
my $path = $perlvar{'lonDocRoot'}.'/userfiles'; |
my $ua=new LWP::UserAgent; |
foreach my $part (@parts) { |
my $request=new HTTP::Request('GET',&tokenwrapper($uri)); |
$path .= '/'.$part; |
my $response=$ua->request($request); |
if (!-e $path) { |
if ($response->is_success()) { |
mkdir($path,0770); |
$info=$response->content; |
|
} else { |
|
return -1; |
|
} |
|
} |
|
my @parts = ($cdom,$cnum); |
|
if ($filename =~ m|^(.+)/[^/]+$|) { |
|
push @parts, split(/\//,$1); |
|
} |
|
my $path = $perlvar{'lonDocRoot'}.'/userfiles'; |
|
foreach my $part (@parts) { |
|
$path .= '/'.$part; |
|
if (!-e $path) { |
|
mkdir($path,0770); |
|
} |
|
} |
} |
} |
} |
open(FILE,">$file"); |
# now the path exists for sure |
print FILE $info; |
# get a user agent |
close(FILE); |
my $ua=new LWP::UserAgent; |
|
my $transferfile=$file.'.in.transfer'; |
|
# FIXME: this should flock |
|
if (-e $transferfile) { return 'ok'; } |
|
my $request; |
|
$uri=~s/^\///; |
|
$request=new HTTP::Request('GET','http://'.$hostname{&homeserver($cnum,$cdom)}.'/raw/'.$uri); |
|
my $response=$ua->request($request,$transferfile); |
|
# did it work? |
|
if ($response->is_error()) { |
|
unlink($transferfile); |
|
&logthis("Userfile repcopy failed for $uri"); |
|
return -1; |
|
} |
|
# worked, rename the transfer file |
|
rename($transferfile,$file); |
return 'ok'; |
return 'ok'; |
} |
} |
|
|
Line 6929 sub tokenwrapper {
|
Line 7283 sub tokenwrapper {
|
} |
} |
} |
} |
|
|
|
# call with reqtype HEAD: get last modification time |
|
# call with reqtype GET: get the file contents |
|
# Do not call this with reqtype GET for large files! It loads everything into memory |
|
# |
sub getuploaded { |
sub getuploaded { |
my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_; |
my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_; |
$uri=~s/^\///; |
$uri=~s/^\///; |
Line 6954 sub readfile {
|
Line 7312 sub readfile {
|
my $fh; |
my $fh; |
open($fh,"<$file"); |
open($fh,"<$file"); |
my $a=''; |
my $a=''; |
while (<$fh>) { $a .=$_; } |
while (my $line = <$fh>) { $a .= $line; } |
return $a; |
return $a; |
} |
} |
|
|
Line 6970 sub filelocation {
|
Line 7328 sub filelocation {
|
if ($file=~m:^/~:) { # is a contruction space reference |
if ($file=~m:^/~:) { # is a contruction space reference |
$location = $file; |
$location = $file; |
$location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; |
$location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; |
} elsif ($file=~m:^/home/[^/]*/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=~/^\/*(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)/+([^/]+)/+([^/]+)/+(.*)$-); |
($file=~m -^/+(?:uploaded|editupload)/+($match_domain)/+($match_name)/+(.*)$-); |
my $home=&homeserver($uname,$udom); |
my $home=&homeserver($uname,$udom); |
my $is_me=0; |
my $is_me=0; |
my @ids=¤t_machine_ids(); |
my @ids=¤t_machine_ids(); |
Line 7012 sub hreflocation {
|
Line 7370 sub hreflocation {
|
} |
} |
if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) { |
if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) { |
$file=~s-^\Q$perlvar{'lonDocRoot'}\E--; |
$file=~s-^\Q$perlvar{'lonDocRoot'}\E--; |
} elsif ($file=~m-/home/(\w+)/public_html/-) { |
} elsif ($file=~m-/home/($match_username)/public_html/-) { |
$file=~s-^/home/(\w+)/public_html/-/~$1/-; |
$file=~s-^/home/($match_username)/public_html/-/~$1/-; |
} elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) { |
} elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) { |
$file=~s-^/home/httpd/lonUsers/([^/]*)/./././([^/]*)/userfiles/ |
$file=~s-^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/ |
-/uploaded/$1/$2/-x; |
-/uploaded/$1/$2/-x; |
} |
} |
return $file; |
return $file; |
Line 7045 sub current_machine_ids {
|
Line 7403 sub current_machine_ids {
|
return @ids; |
return @ids; |
} |
} |
|
|
|
sub additional_machine_domains { |
|
my @domains; |
|
open(my $fh,"<$perlvar{'lonTabDir'}/expected_domains.tab"); |
|
while( my $line = <$fh>) { |
|
$line =~ s/\s//g; |
|
push(@domains,$line); |
|
} |
|
return @domains; |
|
} |
|
|
|
sub default_login_domain { |
|
my $domain = $perlvar{'lonDefDomain'}; |
|
my $testdomain=(split(/\./,$ENV{'HTTP_HOST'}))[0]; |
|
foreach my $posdom (¤t_machine_domains(), |
|
&additional_machine_domains()) { |
|
if (lc($posdom) eq lc($testdomain)) { |
|
$domain=$posdom; |
|
last; |
|
} |
|
} |
|
return $domain; |
|
} |
|
|
# ------------------------------------------------------------- Declutters URLs |
# ------------------------------------------------------------- Declutters URLs |
|
|
sub declutter { |
sub declutter { |
Line 7093 sub clutter {
|
Line 7474 sub clutter {
|
return $thisfn; |
return $thisfn; |
} |
} |
|
|
|
sub clutter_with_no_wrapper { |
|
my $uri = &clutter(shift); |
|
if ($uri =~ m-^/adm/-) { |
|
$uri =~ s-^/adm/wrapper/-/-; |
|
$uri =~ s-^/adm/coursedocs/showdoc/-/-; |
|
} |
|
return $uri; |
|
} |
|
|
sub freeze_escape { |
sub freeze_escape { |
my ($value)=@_; |
my ($value)=@_; |
if (ref($value)) { |
if (ref($value)) { |
Line 7156 BEGIN {
|
Line 7546 BEGIN {
|
%domain_auth_arg_def = (); |
%domain_auth_arg_def = (); |
my $fh; |
my $fh; |
if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) { |
if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) { |
while (<$fh>) { |
while (my $line = <$fh>) { |
next if (/^(\#|\s*$)/); |
next if ($line =~ /^(\#|\s*$)/); |
# next if /^\#/; |
# next if /^\#/; |
chomp; |
chomp $line; |
my ($domain, $domain_description, $def_auth, $def_auth_arg, |
my ($domain, $domain_description, $def_auth, $def_auth_arg, |
$def_lang, $city, $longi, $lati, $primary) = split(/:/,$_); |
$def_lang, $city, $longi, $lati, $primary) = split(/:/,$line,9); |
$domain_auth_def{$domain}=$def_auth; |
$domain_auth_def{$domain}=$def_auth; |
$domain_auth_arg_def{$domain}=$def_auth_arg; |
$domain_auth_arg_def{$domain}=$def_auth_arg; |
$domaindescription{$domain}=$domain_description; |
$domaindescription{$domain}=$domain_description; |
Line 7208 sub get_iphost {
|
Line 7598 sub get_iphost {
|
if (!exists($name_to_ip{$name})) { |
if (!exists($name_to_ip{$name})) { |
$ip = gethostbyname($name); |
$ip = gethostbyname($name); |
if (!$ip || length($ip) ne 4) { |
if (!$ip || length($ip) ne 4) { |
&logthis("Skipping host $id name $name no IP found\n"); |
&logthis("Skipping host $id name $name no IP found"); |
next; |
next; |
} |
} |
$ip=inet_ntoa($ip); |
$ip=inet_ntoa($ip); |
Line 7491 B<delenv($regexp)>: removes all items fr
|
Line 7881 B<delenv($regexp)>: removes all items fr
|
environment file that matches the regular expression in $regexp. The |
environment file that matches the regular expression in $regexp. The |
values are also delted from the current processes %env. |
values are also delted from the current processes %env. |
|
|
|
=item * get_env_multiple($name) |
|
|
|
gets $name from the %env hash, it seemlessly handles the cases where multiple |
|
values may be defined and end up as an array ref. |
|
|
|
returns an array of values |
|
|
=back |
=back |
|
|
=head2 User Information |
=head2 User Information |
Line 7553 passed in @what from the requested user'
|
Line 7950 passed in @what from the requested user'
|
|
|
=item * |
=item * |
|
|
allowed($priv,$uri) : check for a user privilege; returns codes for allowed |
allowed($priv,$uri,$symb,$role) : check for a user privilege; returns codes for allowed actions |
actions |
|
F: full access |
F: full access |
U,I,K: authentication modes (cxx only) |
U,I,K: authentication modes (cxx only) |
'': forbidden |
'': forbidden |
Line 7573 and course level
|
Line 7969 and course level
|
plaintext($short) : return value in %prp hash (rolesplain.tab); plain text |
plaintext($short) : return value in %prp hash (rolesplain.tab); plain text |
explanation of a user role term |
explanation of a user role term |
|
|
|
=item * |
|
|
|
get_my_roles($uname,$udom,$types,$roles,$roledoms) : All arguments are optional. Returns a hash of a user's roles, with keys set to colon-sparated $uname,$udom,and $role, and value set to colon-separated start and end times for the role. If no username and domain are specified, will default to current user/domain. Types, roles, and roledoms are references to arrays, of role statuses (active, future or previous), roles (e.g., cc,in, st etc.) and domains of the roles which can be used to restrict the list if roles reported. If no array ref is provided for types, will default to return only active roles. |
=back |
=back |
|
|
=head2 User Modification |
=head2 User Modification |
Line 7994 reference filled in from namesp (encrypt
|
Line 8393 reference filled in from namesp (encrypt
|
log($udom,$name,$home,$message) : write to permanent log for user; use |
log($udom,$name,$home,$message) : write to permanent log for user; use |
critical subroutine |
critical subroutine |
|
|
|
=item * |
|
|
|
get_dom($namespace,$storearr,$udomain) : returns hash with keys from array |
|
reference filled in from namespace found in domain level on primary domain server ($udomain is optional) |
|
|
|
=item * |
|
|
|
put_dom($namespace,$storehash,$udomain) : stores hash in namespace at domain level on primary domain server ($udomain is optional) |
|
|
=back |
=back |
|
|
=head2 Network Status Functions |
=head2 Network Status Functions |