|
version 1.799, 2006/10/23 21:22:44
|
version 1.833, 2007/02/18 01:51:20
|
|
Line 53 use Time::HiRes qw( gettimeofday tv_inte
|
Line 53 use Time::HiRes qw( gettimeofday tv_inte
|
| use Cache::Memcached; |
use Cache::Memcached; |
| use Digest::MD5; |
use Digest::MD5; |
| use Math::Random; |
use Math::Random; |
| use lib '/home/httpd/lib/perl'; |
use LONCAPA qw(:DEFAULT :match); |
| use LONCAPA; |
|
| use LONCAPA::Configuration; |
use LONCAPA::Configuration; |
| |
|
| my $readit; |
my $readit; |
|
Line 368 sub transfer_profile_to_env {
|
Line 367 sub transfer_profile_to_env {
|
| } |
} |
| } |
} |
| |
|
| |
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 382 sub appenv {
|
Line 401 sub appenv {
|
| $env{$key}=$newenv{$key}; |
$env{$key}=$newenv{$key}; |
| } |
} |
| } |
} |
| if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(), |
open(my $env_file,$env{'user.environment'}); |
| 0640)) { |
if (&timed_flock($env_file,LOCK_EX) |
| |
&& |
| |
tie(my %disk_env,'GDBM_File',$env{'user.environment'}, |
| |
(&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { |
| while (my ($key,$value) = each(%newenv)) { |
while (my ($key,$value) = each(%newenv)) { |
| $disk_env{$key} = $value; |
$disk_env{$key} = $value; |
| } |
} |
|
Line 400 sub delenv {
|
Line 422 sub delenv {
|
| "Attempt to delete from environment ".$delthis); |
"Attempt to delete from environment ".$delthis); |
| return 'error'; |
return 'error'; |
| } |
} |
| if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(), |
open(my $env_file,$env{'user.environment'}); |
| 0640)) { |
if (&timed_flock($env_file,LOCK_EX) |
| |
&& |
| |
tie(my %disk_env,'GDBM_File',$env{'user.environment'}, |
| |
(&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { |
| foreach my $key (keys(%disk_env)) { |
foreach my $key (keys(%disk_env)) { |
| if ($key=~/^$delthis/) { |
if ($key=~/^$delthis/) { |
| delete($env{$key}); |
delete($env{$key}); |
|
Line 588 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 664 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 675 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 827 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 858 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 1116 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 1364 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 1641 sub removeuserfile {
|
Line 1730 sub removeuserfile {
|
| if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) { |
if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) { |
| my $metafile = $fname.'.meta'; |
my $metafile = $fname.'.meta'; |
| my $metaresult = &removeuserfile($docuname,$docudom,$metafile); |
my $metaresult = &removeuserfile($docuname,$docudom,$metafile); |
| |
my $url = "/uploaded/$docudom/$docuname/$fname"; |
| |
my ($file,$group) = (&parse_portfolio_url($url))[3,4]; |
| |
my $sqlresult = |
| |
&update_portfolio_table($docuname,$docudom,$file, |
| |
'portfolio_metadata',$group, |
| |
'delete'); |
| } |
} |
| } |
} |
| return $result; |
return $result; |
|
Line 1663 sub renameuserfile {
|
Line 1758 sub renameuserfile {
|
| my $newmeta = $new.'.meta'; |
my $newmeta = $new.'.meta'; |
| my $metaresult = |
my $metaresult = |
| &renameuserfile($docuname,$docudom,$oldmeta,$newmeta); |
&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; |
return $result; |
|
Line 1691 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 1719 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 1729 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 1750 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 1761 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 1834 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 1898 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 1927 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 1960 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 1990 sub courseiddump {
|
Line 2114 sub courseiddump {
|
| 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($regexp_ok), |
&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 2024 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 2048 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 2274 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 2574 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 2610 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 2643 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 2690 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 2725 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 2759 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 2845 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 2876 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 2891 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 2909 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 2920 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 2935 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 2947 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 2986 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 2998 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 3019 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 3044 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 3105 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 3158 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 3187 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 3199 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 3210 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 3219 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 3254 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 3329 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 3342 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 3437 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 3473 sub is_portfolio_file {
|
Line 3638 sub is_portfolio_file {
|
| |
|
| 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 3506 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 3524 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 3695 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 3800 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 3867 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 3920 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 3929 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 3938 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 3986 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 4007 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 4029 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 4199 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 4296 sub auto_instcode_defaults {
|
Line 4494 sub auto_instcode_defaults {
|
| $returnhash->{&unescape($name)}=&unescape($value); |
$returnhash->{&unescape($name)}=&unescape($value); |
| } |
} |
| } |
} |
| |
$ok_response = 1; |
| } |
} |
| $ok_response = 1; |
|
| } |
} |
| if ($ok_response) { |
if ($ok_response) { |
| return 'ok'; |
return 'ok'; |
|
Line 4317 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 4326 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 4349 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 4370 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 4379 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 4418 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 4458 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 4468 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 4478 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 4558 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 4708 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 4767 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 4844 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 4902 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 4975 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 5122 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 5257 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 5287 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 5338 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 5362 sub stat_file {
|
Line 5643 sub stat_file {
|
| 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 5949 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 6316 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 6465 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 6609 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 6666 sub rndseed_64bit {
|
Line 6948 sub rndseed_64bit {
|
| #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
#&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
| #&logthis("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 6689 sub rndseed_64bit2 {
|
Line 6970 sub rndseed_64bit2 {
|
| my $num2=$nameseed+$domainseed+$courseseed; |
my $num2=$nameseed+$domainseed+$courseseed; |
| #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
#&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
| #&logthis("rndseed :$num:$symb"); |
#&logthis("rndseed :$num:$symb"); |
| |
if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } |
| return "$num1,$num2"; |
return "$num1,$num2"; |
| } |
} |
| } |
} |
|
Line 6926 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 7002 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 7027 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 7043 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 7085 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 7118 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 7238 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 7290 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 7642 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 7662 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 8083 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 |
![[BACK]](/icons/back.gif){kind=icon}
Return to lonnet.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / lonnet / perl