version 1.821, 2007/01/03 02:00:38
|
version 1.824.2.3, 2007/03/17 04:13:06
|
Line 367 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 381 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 399 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 964 my %remembered;
|
Line 990 my %remembered;
|
my %accessed; |
my %accessed; |
my $kicks=0; |
my $kicks=0; |
my $hits=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 { |
sub devalidate_cache_new { |
my ($name,$id,$debug) = @_; |
my ($name,$id,$debug) = @_; |
if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); } |
if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); } |
$id=&escape($name.':'.$id); |
$id=&make_key($name,$id); |
$memcache->delete($id); |
$memcache->delete($id); |
delete($remembered{$id}); |
delete($remembered{$id}); |
delete($accessed{$id}); |
delete($accessed{$id}); |
Line 975 sub devalidate_cache_new {
|
Line 1007 sub devalidate_cache_new {
|
|
|
sub is_cached_new { |
sub is_cached_new { |
my ($name,$id,$debug) = @_; |
my ($name,$id,$debug) = @_; |
$id=&escape($name.':'.$id); |
$id=&make_key($name,$id); |
if (exists($remembered{$id})) { |
if (exists($remembered{$id})) { |
if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); } |
if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); } |
$accessed{$id}=[&gettimeofday()]; |
$accessed{$id}=[&gettimeofday()]; |
Line 998 sub is_cached_new {
|
Line 1030 sub is_cached_new {
|
|
|
sub do_cache_new { |
sub do_cache_new { |
my ($name,$id,$value,$time,$debug) = @_; |
my ($name,$id,$value,$time,$debug) = @_; |
$id=&escape($name.':'.$id); |
$id=&make_key($name,$id); |
my $setvalue=$value; |
my $setvalue=$value; |
if (!defined($setvalue)) { |
if (!defined($setvalue)) { |
$setvalue='__undef__'; |
$setvalue='__undef__'; |
Line 1701 sub removeuserfile {
|
Line 1733 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 ($group,$file); |
my $url = "/uploaded/$docudom/$docuname/$fname"; |
if ($fname =~ /^groups\/(\w+)\/portfolio(\/.+)$/) { |
my ($file,$group) = (&parse_portfolio_url($url))[3,4]; |
$group = $1; |
|
$file = $2; |
|
} elsif ($fname =~ /^portfolio(\/.+)$/) { |
|
$file = $1; |
|
} |
|
my $sqlresult = |
my $sqlresult = |
&update_portfolio_table($docuname,$docudom,$group.$file, |
&update_portfolio_table($docuname,$docudom,$file, |
'portfolio_metadata',$group, |
'portfolio_metadata',$group, |
'delete'); |
'delete'); |
} |
} |
Line 1734 sub renameuserfile {
|
Line 1761 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 ($group,$file); |
my $url = "/uploaded/$docudom/$docuname/$old"; |
if ($old =~ /^groups\/(\w+)\/portfolio(\/.+)$/) { |
my ($file,$group) = (&parse_portfolio_url($url))[3,4]; |
$group = $1; |
|
$file = $2; |
|
} elsif ($old =~ /^portfolio(\/.+)$/) { |
|
$file = $1; |
|
} |
|
my $sqlresult = |
my $sqlresult = |
&update_portfolio_table($docuname,$docudom,$group.$file, |
&update_portfolio_table($docuname,$docudom,$file, |
'portfolio_metadata',$group, |
'portfolio_metadata',$group, |
'delete'); |
'delete'); |
} |
} |
Line 3070 sub dump {
|
Line 3092 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 3104 sub currentdump {
|
Line 3142 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 3129 sub convert_dump_to_currentdump{
|
Line 3167 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 3541 sub parse_portfolio_url {
|
Line 3581 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 7133 sub repcopy_userfile {
|
Line 7173 sub repcopy_userfile {
|
} else { |
} else { |
my $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode); |
my $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode); |
if ($lwpresp ne 'ok') { |
if ($lwpresp ne 'ok') { |
my $ua=new LWP::UserAgent; |
return -1; |
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); |
my @parts = ($cdom,$cnum); |
if ($filename =~ m|^(.+)/[^/]+$|) { |
if ($filename =~ m|^(.+)/[^/]+$|) { |
Line 7294 sub current_machine_ids {
|
Line 7327 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 { |