|
version 1.802, 2006/11/10 02:04:31
|
version 1.832, 2007/02/16 01:04:19
|
|
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 694 sub idput {
|
Line 719 sub idput {
|
| } |
} |
| } |
} |
| |
|
| |
# ------------------------------------------- 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"); |
| |
} |
| |
} |
| |
|
| # --------------------------------------------------- Assign a key to a student |
# --------------------------------------------------- Assign a key to a student |
| |
|
| sub assign_access_key { |
sub assign_access_key { |
|
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 my $line (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(/\=/,$line,2); |
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 1728 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 1749 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 1925 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= |
|
Line 1935 sub get_my_roles {
|
Line 2037 sub get_my_roles {
|
| foreach my $entry (keys(%dumphash)) { |
foreach my $entry (keys(%dumphash)) { |
| my ($tend,$tstart)=split(/\:/,$dumphash{$entry}); |
my ($tend,$tstart)=split(/\:/,$dumphash{$entry}); |
| if (($tstart) && ($tstart<0)) { next; } |
if (($tstart) && ($tstart<0)) { next; } |
| if (($tend) && ($tend<$now)) { next; } |
my $status = 'active'; |
| if (($tstart) && ($now<$tstart)) { next; } |
if (($tend) && ($tend<$now)) { |
| |
$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); |
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 2688 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 2763 sub rolesinit {
|
Line 2890 sub rolesinit {
|
| $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 2843 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 2874 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 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 2999 sub getkeys {
|
Line 3142 sub getkeys {
|
| my $rep=reply("keys:$udomain:$uname:$namespace",$uhome); |
my $rep=reply("keys:$udomain:$uname:$namespace",$uhome); |
| my @keyarray=(); |
my @keyarray=(); |
| foreach my $key (split(/\&/,$rep)) { |
foreach my $key (split(/\&/,$rep)) { |
| |
next if ($key =~ /^error: 2 /); |
| push(@keyarray,&unescape($key)); |
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=(); |
|
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 3257 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 3332 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 3345 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 3440 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 3476 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 my $right (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) { |
foreach my $right (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) { |
| my ($effect,$realm,$role)=split(/\:/,$right); |
my ($effect,$realm,$role)=split(/\:/,$right); |
|
Line 3509 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 3527 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 3803 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 3870 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 3996 sub log_query {
|
Line 4179 sub log_query {
|
| 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 4299 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 4320 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 4329 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 4352 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 4373 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 4382 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 4421 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 4461 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 4471 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 4481 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 4561 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 4847 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 5125 sub modify_access_controls {
|
Line 5354 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 5336 sub dirlist {
|
Line 5621 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 5360 sub stat_file {
|
Line 5645 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 5947 sub metadata {
|
Line 6232 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 6607 sub rndseed {
|
Line 6892 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 6664 sub rndseed_64bit {
|
Line 6950 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 6687 sub rndseed_64bit2 {
|
Line 6972 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 6924 sub repcopy_userfile {
|
Line 7210 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 7000 sub tokenwrapper {
|
Line 7285 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 7041 sub filelocation {
|
Line 7330 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 7083 sub hreflocation {
|
Line 7372 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 7116 sub current_machine_ids {
|
Line 7405 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 7288 sub get_iphost {
|
Line 7600 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 7640 passed in @what from the requested user'
|
Line 7952 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 7660 and course level
|
Line 7971 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 8081 reference filled in from namesp (encrypt
|
Line 8395 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