version 1.814, 2006/12/11 14:06:05
|
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 qw(:DEFAULT :match); |
use LONCAPA::Configuration; |
use LONCAPA::Configuration; |
|
|
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 878 sub devalidate_getsection_cache {
|
Line 903 sub devalidate_getsection_cache {
|
&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; |
Line 901 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 1159 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 1407 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 1684 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 1706 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 1969 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 1979 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 3031 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 3065 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 3090 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 3502 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/($match_domain)/($match_username)/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/($match_domain)/($match_courseid)/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 3527 sub is_portfolio_url {
|
Line 3627 sub is_portfolio_url {
|
|
|
sub is_portfolio_file { |
sub is_portfolio_file { |
my ($file) = @_; |
my ($file) = @_; |
if (($file =~ /^portfolio/) || ($file =~ /^groups\/\w\/portfolio/)) { |
if (($file =~ /^portfolio/) || ($file =~ /^groups\/\w+\/portfolio/)) { |
return 1; |
return 1; |
} |
} |
return; |
return; |
Line 3539 sub is_portfolio_file {
|
Line 3639 sub is_portfolio_file {
|
sub customaccess { |
sub customaccess { |
my ($priv,$uri)=@_; |
my ($priv,$uri)=@_; |
my ($urole,$urealm)=split(/\./,$env{'request.role'},2); |
my ($urole,$urealm)=split(/\./,$env{'request.role'},2); |
my ($udom,$ucrs,$usec)=split(/\//,$urealm); |
my (undef,$udom,$ucrs,$usec)=split(/\//,$urealm); |
$udom = &LONCAPA::clean_domain($udom); |
$udom = &LONCAPA::clean_domain($udom); |
$ucrs = &LONCAPA::clean_username($ucrs); |
$ucrs = &LONCAPA::clean_username($ucrs); |
my $access=0; |
my $access=0; |
Line 4079 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 4494 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 5026 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 5246 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 7047 sub repcopy_userfile {
|
Line 7209 sub repcopy_userfile {
|
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/+($match_domain)/+($match_name)/+(.*)|); |
($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 7122 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 7238 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 7410 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 7781 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 |