--- loncom/lonnet/perl/lonnet.pm 2006/12/01 21:52:30 1.811
+++ loncom/lonnet/perl/lonnet.pm 2007/01/29 21:16:55 1.831
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.811 2006/12/01 21:52:30 albertel Exp $
+# $Id: lonnet.pm,v 1.831 2007/01/29 21:16:55 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -53,7 +53,6 @@ use Time::HiRes qw( gettimeofday tv_inte
use Cache::Memcached;
use Digest::MD5;
use Math::Random;
-use lib '/home/httpd/lib/perl';
use LONCAPA qw(:DEFAULT :match);
use LONCAPA::Configuration;
@@ -368,6 +367,26 @@ 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
sub appenv {
@@ -382,8 +401,11 @@ sub appenv {
$env{$key}=$newenv{$key};
}
}
- if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(),
- 0640)) {
+ open(my $env_file,$env{'user.environment'});
+ 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)) {
$disk_env{$key} = $value;
}
@@ -400,8 +422,11 @@ sub delenv {
"Attempt to delete from environment ".$delthis);
return 'error';
}
- if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(),
- 0640)) {
+ open(my $env_file,$env{'user.environment'});
+ 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)) {
if ($key=~/^$delthis/) {
delete($env{$key});
@@ -878,6 +903,25 @@ sub devalidate_getsection_cache {
&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 {
my ($udom,$unam,$courseid)=@_;
my $cachetime=1800;
@@ -901,14 +945,13 @@ sub getsection {
# If there is more than one expired role, choose the one which ended last.
# If there is a role which has expired, return it.
#
- foreach my $line (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',
- &homeserver($unam,$udom)))) {
- my ($key,$value)=split(/\=/,$line,2);
- $key=&unescape($key);
+ $courseid = &courseid_to_courseurl($courseid);
+ my %roleshash = &dump('roles',$udom,$unam,$courseid);
+ foreach my $key (keys(%roleshash)) {
next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/);
my $section=$1;
if ($key eq $courseid.'_st') { $section=''; }
- my ($dummy,$end,$start)=split(/\_/,&unescape($value));
+ my ($dummy,$end,$start)=split(/\_/,&unescape($roleshash{$key}));
my $now=time;
if (defined($end) && $end && ($now > $end)) {
$Expired{$end}=$section;
@@ -1159,6 +1202,7 @@ sub repcopy {
}
$filename=~s/[\n\r]//g;
my $transname="$filename.in.transfer";
+# FIXME: this should flock
if ((-e $filename) || (-e $transname)) { return 'ok'; }
my $remoteurl=subscribe($filename);
if ($remoteurl =~ /^con_lost by/) {
@@ -1407,15 +1451,17 @@ sub store_edited_file {
}
sub clean_filename {
- my ($fname)=@_;
+ my ($fname,$args)=@_;
# Replace Windows backslashes by forward slashes
$fname=~s/\\/\//g;
-# Get rid of everything but the actual filename
- $fname=~s/^.*\/([^\/]+)$/$1/;
+ if (!$args->{'keep_path'}) {
+ # Get rid of everything but the actual filename
+ $fname=~s/^.*\/([^\/]+)$/$1/;
+ }
# Replace spaces by underscores
$fname=~s/\s+/\_/g;
# 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
# numbers
$fname=~s/\.(\d+)(?=\.)/_$1/g;
@@ -1684,6 +1730,12 @@ sub removeuserfile {
if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) {
my $metafile = $fname.'.meta';
my $metaresult = &removeuserfile($docuname,$docudom,$metafile);
+ my $url = "/uploaded/$docudom/$docuname/$fname";
+ my ($file,$group) = (&parse_portfolio_url($url))[3,4];
+ my $sqlresult =
+ &update_portfolio_table($docuname,$docudom,$file,
+ 'portfolio_metadata',$group,
+ 'delete');
}
}
return $result;
@@ -1706,6 +1758,12 @@ sub renameuserfile {
my $newmeta = $new.'.meta';
my $metaresult =
&renameuserfile($docuname,$docudom,$oldmeta,$newmeta);
+ my $url = "/uploaded/$docudom/$docuname/$old";
+ my ($file,$group) = (&parse_portfolio_url($url))[3,4];
+ my $sqlresult =
+ &update_portfolio_table($docuname,$docudom,$file,
+ 'portfolio_metadata',$group,
+ 'delete');
}
}
return $result;
@@ -3031,7 +3089,23 @@ sub dump {
sub dumpstore {
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
@@ -3044,6 +3118,7 @@ sub getkeys {
my $rep=reply("keys:$udomain:$uname:$namespace",$uhome);
my @keyarray=();
foreach my $key (split(/\&/,$rep)) {
+ next if ($key =~ /^error: 2 /);
push(@keyarray,&unescape($key));
}
return @keyarray;
@@ -3064,7 +3139,7 @@ sub currentdump {
if ($rep eq "unknown_cmd") {
# an old lond will not know 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)/);
my %hash = @tmp;
@tmp=();
@@ -3089,6 +3164,8 @@ sub convert_dump_to_currentdump{
# we might run in to problems with parameter names =~ /^v\./
while (my ($key,$value) = each(%hash)) {
my ($v,$symb,$param) = split(/:/,$key);
+ $symb = &unescape($symb);
+ $param = &unescape($param);
next if ($v eq 'version' || $symb eq 'keys');
next if (exists($returnhash{$symb}) &&
exists($returnhash{$symb}->{$param}) &&
@@ -3302,6 +3379,22 @@ sub portfolio_access {
my ($requrl) = @_;
my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl);
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') {
return 'F';
} elsif ($result =~ /^[^:]+:guest_/) {
@@ -3485,12 +3578,12 @@ sub parse_portfolio_url {
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;
$udom = $1;
$unum = $2;
$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;
$udom = $1;
$unum = $2;
@@ -3510,7 +3603,7 @@ sub is_portfolio_url {
sub is_portfolio_file {
my ($file) = @_;
- if (($file =~ /^portfolio/) || ($file =~ /^groups\/\w\/portfolio/)) {
+ if (($file =~ /^portfolio/) || ($file =~ /^groups\/\w+\/portfolio/)) {
return 1;
}
return;
@@ -3522,7 +3615,7 @@ sub is_portfolio_file {
sub customaccess {
my ($priv,$uri)=@_;
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);
$ucrs = &LONCAPA::clean_username($ucrs);
my $access=0;
@@ -3582,7 +3675,14 @@ sub allowed {
my ($space,$domain,$name,@dir)=split('/',$uri);
if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) &&
($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.
@@ -3858,6 +3958,8 @@ sub allowed {
unless ($env{'request.course.id'}) {
if ($thisallowed eq 'A') {
return 'A';
+ } elsif ($thisallowed eq 'B') {
+ return 'B';
} else {
return '1';
}
@@ -3925,6 +4027,8 @@ sub allowed {
if ($thisallowed eq 'A') {
return 'A';
+ } elsif ($thisallowed eq 'B') {
+ return 'B';
}
return 'F';
}
@@ -4051,6 +4155,18 @@ sub log_query {
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)
sub fetch_enrollment_query {
@@ -4466,38 +4582,34 @@ sub get_users_groups {
@usersgroups = split(/:/,$grouplist);
} else {
$grouplist = '';
- my %roleshash = &dump('roles',$udom,$uname,$courseid);
- my ($tmp) = keys(%roleshash);
- if ($tmp=~/^error:/) {
- &logthis('Error retrieving roles: '.$tmp.' for '.$uname.':'.$udom);
- } else {
- my $access_end = $env{'course.'.$courseid.
- '.default_enrollment_end_date'};
- my $now = time;
- foreach my $key (keys(%roleshash)) {
- if ($key =~ /^\Q$courseid\E\/(\w+)\_gr$/) {
- my $group = $1;
- if ($roleshash{$key} =~ /_(\d+)_(\d+)$/) {
- my $start = $2;
- my $end = $1;
- if ($start == -1) { next; } # deleted from group
- if (($start!=0) && ($start>$now)) { next; }
- if (($end!=0) && ($end<$now)) {
- if ($access_end && $access_end < $now) {
- if ($access_end - $end < 86400) {
- push(@usersgroups,$group);
- }
+ my $courseurl = &courseid_to_courseurl($courseid);
+ my %roleshash = &dump('roles',$udom,$uname,$courseurl);
+ my $access_end = $env{'course.'.$courseid.
+ '.default_enrollment_end_date'};
+ my $now = time;
+ foreach my $key (keys(%roleshash)) {
+ if ($key =~ /^\Q$courseurl\E\/(\w+)\_gr$/) {
+ my $group = $1;
+ if ($roleshash{$key} =~ /_(\d+)_(\d+)$/) {
+ my $start = $2;
+ my $end = $1;
+ if ($start == -1) { next; } # deleted from group
+ if (($start!=0) && ($start>$now)) { next; }
+ if (($end!=0) && ($end<$now)) {
+ 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;
}
@@ -4930,6 +5042,16 @@ ENDINITMAP
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
sub assigncustomrole {
@@ -5208,12 +5330,68 @@ sub modify_access_controls {
# remove lock
my @del_lock = ($file_name."\0".'locked_access_records');
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 {
$outcome = "error: could not obtain lockfile\n";
}
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
sub get_marked_as_readonly {
@@ -7009,60 +7187,59 @@ sub repcopy_userfile {
if ($file =~ m|^/home/httpd/html/lonUsers/|) { return 'ok'; }
my ($cdom,$cnum,$filename) =
($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)|);
- my ($info,$rtncode);
my $uri="/uploaded/$cdom/$cnum/$filename";
if (-e "$file") {
+# we already have a local copy, check it out
my @fileinfo = stat($file);
+ my $rtncode;
+ my $info;
my $lwpresp = &getuploaded('HEAD',$uri,$cdom,$cnum,\$info,\$rtncode);
if ($lwpresp ne 'ok') {
+# there is no such file anymore, even though we had a local copy
if ($rtncode eq '404') {
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;
}
if ($info < $fileinfo[9]) {
+# nice, the file we have is up-to-date, just say okay
return 'ok';
+ } else {
+# the file is outdated, get rid of it
+ unlink($file);
}
- $info = '';
- $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);
- if ($lwpresp ne 'ok') {
- return -1;
- }
- } else {
- my $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);
- if ($lwpresp ne 'ok') {
- my $ua=new LWP::UserAgent;
- my $request=new HTTP::Request('GET',&tokenwrapper($uri));
- my $response=$ua->request($request);
- if ($response->is_success()) {
- $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);
- }
+ }
+# one way or the other, at this point, we don't have the file
+# construct the correct path for the file
+ 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");
- print FILE $info;
- close(FILE);
+# now the path exists for sure
+# get a user agent
+ 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';
}
@@ -7084,6 +7261,10 @@ 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 {
my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
$uri=~s/^\///;
@@ -7200,6 +7381,29 @@ sub current_machine_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
sub declutter {
@@ -7372,7 +7576,7 @@ sub get_iphost {
if (!exists($name_to_ip{$name})) {
$ip = gethostbyname($name);
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;
}
$ip=inet_ntoa($ip);