--- loncom/lonnet/perl/lonnet.pm 2007/03/17 04:13:06 1.824.2.3
+++ loncom/lonnet/perl/lonnet.pm 2007/01/18 18:21:10 1.827
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.824.2.3 2007/03/17 04:13:06 albertel Exp $
+# $Id: lonnet.pm,v 1.827 2007/01/18 18:21:10 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -367,26 +367,6 @@ 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 {
@@ -401,11 +381,8 @@ sub appenv {
$env{$key}=$newenv{$key};
}
}
- 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)) {
+ if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(),
+ 0640)) {
while (my ($key,$value) = each(%newenv)) {
$disk_env{$key} = $value;
}
@@ -422,11 +399,8 @@ sub delenv {
"Attempt to delete from environment ".$delthis);
return 'error';
}
- 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)) {
+ if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(),
+ 0640)) {
foreach my $key (keys(%disk_env)) {
if ($key=~/^$delthis/) {
delete($env{$key});
@@ -990,16 +964,10 @@ my %remembered;
my %accessed;
my $kicks=0;
my $hits=0;
-sub make_key {
- my ($name,$id) = @_;
- if (length($id) > 200) { $id=length($id).':'.&Digest::MD5::md5_hex($id); }
- return &escape($name.':'.$id);
-}
-
sub devalidate_cache_new {
my ($name,$id,$debug) = @_;
if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }
- $id=&make_key($name,$id);
+ $id=&escape($name.':'.$id);
$memcache->delete($id);
delete($remembered{$id});
delete($accessed{$id});
@@ -1007,7 +975,7 @@ sub devalidate_cache_new {
sub is_cached_new {
my ($name,$id,$debug) = @_;
- $id=&make_key($name,$id);
+ $id=&escape($name.':'.$id);
if (exists($remembered{$id})) {
if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); }
$accessed{$id}=[&gettimeofday()];
@@ -1030,7 +998,7 @@ sub is_cached_new {
sub do_cache_new {
my ($name,$id,$value,$time,$debug) = @_;
- $id=&make_key($name,$id);
+ $id=&escape($name.':'.$id);
my $setvalue=$value;
if (!defined($setvalue)) {
$setvalue='__undef__';
@@ -5348,6 +5316,53 @@ sub modify_access_controls {
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 {
@@ -7173,7 +7188,18 @@ sub repcopy_userfile {
} else {
my $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);
if ($lwpresp ne 'ok') {
- return -1;
+ my $ua=new LWP::UserAgent;
+ my $request=new HTTP::Request('GET',&tokenwrapper($uri));
+ # FIXME, right reads everything into memory then writes it out
+ # doing something like
+ # my $response=$ua->request($request,$file);
+ # would make this write directly to disk
+ my $response=$ua->request($request);
+ if ($response->is_success()) {
+ $info=$response->content;
+ } else {
+ return -1;
+ }
}
my @parts = ($cdom,$cnum);
if ($filename =~ m|^(.+)/[^/]+$|) {
@@ -7522,7 +7548,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);