version 1.683.2.5, 2006/01/05 19:39:52
|
version 1.704, 2006/01/27 20:37:21
|
Line 124 sub logperm {
|
Line 124 sub logperm {
|
# -------------------------------------------------- Non-critical communication |
# -------------------------------------------------- Non-critical communication |
sub subreply { |
sub subreply { |
my ($cmd,$server)=@_; |
my ($cmd,$server)=@_; |
my $peerfile="$perlvar{'lonSockDir'}/$server"; |
my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server}; |
# |
# |
# With loncnew process trimming, there's a timing hole between lonc server |
# With loncnew process trimming, there's a timing hole between lonc server |
# process exit and the master server picking up the listen on the AF_UNIX |
# process exit and the master server picking up the listen on the AF_UNIX |
Line 152 sub subreply {
|
Line 152 sub subreply {
|
} |
} |
my $answer; |
my $answer; |
if ($client) { |
if ($client) { |
print $client "$cmd\n"; |
print $client "sethost:$server:$cmd\n"; |
$answer=<$client>; |
$answer=<$client>; |
if (!$answer) { $answer="con_lost"; } |
if (!$answer) { $answer="con_lost"; } |
chomp($answer); |
chomp($answer); |
Line 271 sub transfer_profile_to_env {
|
Line 271 sub transfer_profile_to_env {
|
my %Remove; |
my %Remove; |
for ($envi=0;$envi<=$#profile;$envi++) { |
for ($envi=0;$envi<=$#profile;$envi++) { |
chomp($profile[$envi]); |
chomp($profile[$envi]); |
my ($envname,$envvalue)=split(/=/,$profile[$envi]); |
my ($envname,$envvalue)=split(/=/,$profile[$envi],2); |
$env{$envname} = $envvalue; |
$env{$envname} = $envvalue; |
if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) { |
if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) { |
if ($time < time-300) { |
if ($time < time-300) { |
Line 289 sub transfer_profile_to_env {
|
Line 289 sub transfer_profile_to_env {
|
|
|
sub appenv { |
sub appenv { |
my %newenv=@_; |
my %newenv=@_; |
foreach (keys %newenv) { |
foreach my $key (keys(%newenv)) { |
if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) { |
if (($newenv{$key}=~/^user\.role/) || ($newenv{$key}=~/^user\.priv/)) { |
&logthis("<font color=\"blue\">WARNING: ". |
&logthis("<font color=\"blue\">WARNING: ". |
"Attempt to modify environment ".$_." to ".$newenv{$_} |
"Attempt to modify environment ".$key." to ".$newenv{$key} |
.'</font>'); |
.'</font>'); |
delete($newenv{$_}); |
delete($newenv{$key}); |
} else { |
} else { |
$env{$_}=$newenv{$_}; |
$env{$key}=$newenv{$key}; |
} |
} |
} |
} |
|
|
Line 323 sub appenv {
|
Line 323 sub appenv {
|
for (my $i=0; $i<=$#oldenv; $i++) { |
for (my $i=0; $i<=$#oldenv; $i++) { |
chomp($oldenv[$i]); |
chomp($oldenv[$i]); |
if ($oldenv[$i] ne '') { |
if ($oldenv[$i] ne '') { |
my ($name,$value)=split(/=/,$oldenv[$i]); |
my ($name,$value)=split(/=/,$oldenv[$i],2); |
unless (defined($newenv{$name})) { |
unless (defined($newenv{$name})) { |
$newenv{$name}=$value; |
$newenv{$name}=$value; |
} |
} |
Line 380 sub delenv {
|
Line 380 sub delenv {
|
close($fh); |
close($fh); |
return 'error: '.$!; |
return 'error: '.$!; |
} |
} |
foreach (@oldenv) { |
foreach my $cur_key (@oldenv) { |
if ($_=~/^$delthis/) { |
if ($cur_key=~/^$delthis/) { |
my ($key,undef) = split('=',$_); |
my ($key,undef) = split('=',$cur_key,2); |
delete($env{$key}); |
delete($env{$key}); |
} else { |
} else { |
print $fh $_; |
print $fh $cur_key; |
} |
} |
} |
} |
close($fh); |
close($fh); |
Line 1280 sub clean_filename {
|
Line 1280 sub clean_filename {
|
} |
} |
|
|
# --------------- Take an uploaded file and put it into the userfiles directory |
# --------------- Take an uploaded file and put it into the userfiles directory |
# input: name of form element, coursedoc=1 means this is for the course |
# input: $formname - the contents of the file are in $env{"form.$formname"} |
# output: url of file in userspace |
# the desired filenam is in $env{"form.$formname"} |
|
# $coursedoc - if true up to the current course |
|
# if false |
|
# $subdir - directory in userfile to store the file into |
|
# $parser, $allfiles, $codebase - unknown |
|
# |
|
# output: url of file in userspace, or error: <message> |
|
# or /adm/notfound.html if failure to upload occurse |
|
|
|
|
sub userfileupload { |
sub userfileupload { |
Line 1351 sub finishuserfileupload {
|
Line 1358 sub finishuserfileupload {
|
} |
} |
# Save the file |
# Save the file |
{ |
{ |
open(FH,'>'.$filepath.'/'.$file); |
if (!open(FH,'>'.$filepath.'/'.$file)) { |
print FH $env{'form.'.$formname}; |
&logthis('Failed to create '.$filepath.'/'.$file); |
|
print STDERR ('Failed to create '.$filepath.'/'.$file."\n"); |
|
return '/adm/notfound.html'; |
|
} |
|
if (!print FH ($env{'form.'.$formname})) { |
|
&logthis('Failed to write to '.$filepath.'/'.$file); |
|
print STDERR ('Failed to write to '.$filepath.'/'.$file."\n"); |
|
return '/adm/notfound.html'; |
|
} |
close(FH); |
close(FH); |
} |
} |
if ($parser eq 'parse') { |
if ($parser eq 'parse') { |
Line 2778 sub del {
|
Line 2793 sub del {
|
# -------------------------------------------------------------- dump interface |
# -------------------------------------------------------------- dump interface |
|
|
sub dump { |
sub dump { |
my ($namespace,$udomain,$uname,$regexp)=@_; |
my ($namespace,$udomain,$uname,$regexp,$range)=@_; |
if (!$udomain) { $udomain=$env{'user.domain'}; } |
if (!$udomain) { $udomain=$env{'user.domain'}; } |
if (!$uname) { $uname=$env{'user.name'}; } |
if (!$uname) { $uname=$env{'user.name'}; } |
my $uhome=&homeserver($uname,$udomain); |
my $uhome=&homeserver($uname,$udomain); |
Line 2787 sub dump {
|
Line 2802 sub dump {
|
} else { |
} else { |
$regexp='.'; |
$regexp='.'; |
} |
} |
my $rep=reply("dump:$udomain:$uname:$namespace:$regexp",$uhome); |
my $rep=reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome); |
my @pairs=split(/\&/,$rep); |
my @pairs=split(/\&/,$rep); |
my %returnhash=(); |
my %returnhash=(); |
foreach (@pairs) { |
foreach (@pairs) { |
my ($key,$value)=split(/=/,$_); |
my ($key,$value)=split(/=/,$_,2); |
$returnhash{unescape($key)}=&thaw_unescape($value); |
$returnhash{unescape($key)}=&thaw_unescape($value); |
} |
} |
return %returnhash; |
return %returnhash; |
Line 3405 sub is_on_map {
|
Line 3420 sub is_on_map {
|
my $filename=$uriparts[$#uriparts]; |
my $filename=$uriparts[$#uriparts]; |
my $pathname=$uri; |
my $pathname=$uri; |
$pathname=~s|/\Q$filename\E$||; |
$pathname=~s|/\Q$filename\E$||; |
$pathname=~s/^adm\/wrapper\///; |
$pathname=~s/^adm\/wrapper\///; |
|
$pathname=~s/^adm\/coursedocs\/showdoc\///; |
#Trying to find the conditional for the file |
#Trying to find the conditional for the file |
my $match=($env{'acc.res.'.$env{'request.course.id'}.'.'.$pathname}=~ |
my $match=($env{'acc.res.'.$env{'request.course.id'}.'.'.$pathname}=~ |
/\&\Q$filename\E\:([\d\|]+)\&/); |
/\&\Q$filename\E\:([\d\|]+)\&/); |
Line 3729 sub modify_group_roles {
|
Line 3745 sub modify_group_roles {
|
my $role = 'gr/'.&escape($userprivs); |
my $role = 'gr/'.&escape($userprivs); |
my ($uname,$udom) = split(/:/,$user); |
my ($uname,$udom) = split(/:/,$user); |
my $result = &assignrole($udom,$uname,$url,$role,$end,$start); |
my $result = &assignrole($udom,$uname,$url,$role,$end,$start); |
|
if ($result eq 'ok') { |
|
&devalidate_getgroups_cache($udom,$uname,$cdom,$cnum); |
|
} |
|
|
return $result; |
return $result; |
} |
} |
|
|
Line 4812 sub EXT {
|
Line 4832 sub EXT {
|
return $env{'course.'.$courseid.'.'.$spacequalifierrest}; |
return $env{'course.'.$courseid.'.'.$spacequalifierrest}; |
} elsif ($realm eq 'resource') { |
} elsif ($realm eq 'resource') { |
|
|
my $section; |
|
if (defined($courseid) && $courseid eq $env{'request.course.id'}) { |
if (defined($courseid) && $courseid eq $env{'request.course.id'}) { |
if (!$symbparm) { $symbparm=&symbread(); } |
if (!$symbparm) { $symbparm=&symbread(); } |
} |
} |
|
|
|
if ($space eq 'title') { |
|
if (!$symbparm) { $symbparm = $env{'request.filename'}; } |
|
return &gettitle($symbparm); |
|
} |
|
|
|
if ($space eq 'map') { |
|
my ($map) = &decode_symb($symbparm); |
|
return &symbread($map); |
|
} |
|
|
|
my ($section, $group, @groups); |
my ($courselevelm,$courselevel); |
my ($courselevelm,$courselevel); |
if ($symbparm && defined($courseid) && |
if ($symbparm && defined($courseid) && |
$courseid eq $env{'request.course.id'}) { |
$courseid eq $env{'request.course.id'}) { |
Line 4832 sub EXT {
|
Line 4863 sub EXT {
|
if (($env{'user.name'} eq $uname) && |
if (($env{'user.name'} eq $uname) && |
($env{'user.domain'} eq $udom)) { |
($env{'user.domain'} eq $udom)) { |
$section=$env{'request.course.sec'}; |
$section=$env{'request.course.sec'}; |
|
@groups=&sort_course_groups($env{'request.course.groups'},$courseid); |
|
if (@groups > 0) { |
|
@groups = sort(@groups); |
|
} |
} else { |
} else { |
if (! defined($usection)) { |
if (! defined($usection)) { |
$section=&getsection($udom,$uname,$courseid); |
$section=&getsection($udom,$uname,$courseid); |
} else { |
} else { |
$section = $usection; |
$section = $usection; |
} |
} |
|
my $grouplist = &get_users_groups($udom,$uname,$courseid); |
|
if ($grouplist) { |
|
@groups=&sort_course_groups($grouplist,$courseid); |
|
} |
} |
} |
|
|
my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest; |
my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest; |
Line 4853 sub EXT {
|
Line 4892 sub EXT {
|
my $userreply=&resdata($uname,$udom,'user', |
my $userreply=&resdata($uname,$udom,'user', |
($courselevelr,$courselevelm, |
($courselevelr,$courselevelm, |
$courselevel)); |
$courselevel)); |
|
|
if (defined($userreply)) { return $userreply; } |
if (defined($userreply)) { return $userreply; } |
|
|
# ------------------------------------------------ second, check some of course |
# ------------------------------------------------ second, check some of course |
|
my $coursereply; |
|
if (@groups > 0) { |
|
$coursereply = &check_group_parms($courseid,\@groups,$symbparm, |
|
$mapparm,$spacequalifierrest); |
|
if (defined($coursereply)) { return $coursereply; } |
|
} |
|
|
my $coursereply=&resdata($env{'course.'.$courseid.'.num'}, |
$coursereply=&resdata($env{'course.'.$courseid.'.num'}, |
$env{'course.'.$courseid.'.domain'}, |
$env{'course.'.$courseid.'.domain'}, |
'course', |
'course', |
($seclevelr,$seclevelm,$seclevel, |
($seclevelr,$seclevelm,$seclevel, |
Line 4929 sub EXT {
|
Line 4973 sub EXT {
|
if ($space eq 'time') { |
if ($space eq 'time') { |
return time; |
return time; |
} |
} |
|
} elsif ($realm eq 'server') { |
|
# ----------------------------------------------------------------- system.time |
|
if ($space eq 'name') { |
|
return $ENV{'SERVER_NAME'}; |
|
} |
} |
} |
return ''; |
return ''; |
} |
} |
|
|
|
sub check_group_parms { |
|
my ($courseid,$groups,$symbparm,$mapparm,$what) = @_; |
|
my @groupitems = (); |
|
my $resultitem; |
|
my @levels = ($symbparm,$mapparm,$what); |
|
foreach my $group (@{$groups}) { |
|
foreach my $level (@levels) { |
|
my $item = $courseid.'.['.$group.'].'.$level; |
|
push(@groupitems,$item); |
|
} |
|
} |
|
my $coursereply = &resdata($env{'course.'.$courseid.'.num'}, |
|
$env{'course.'.$courseid.'.domain'}, |
|
'course',@groupitems); |
|
return $coursereply; |
|
} |
|
|
|
sub sort_course_groups { # Sort groups based on defined rankings. Default is sort(). |
|
my ($grouplist,$courseid) = @_; |
|
my @groups = split/:/,$grouplist; |
|
if (@groups > 1) { |
|
@groups = sort(@groups); |
|
} |
|
return @groups; |
|
} |
|
|
sub packages_tab_default { |
sub packages_tab_default { |
my ($uri,$varname)=@_; |
my ($uri,$varname)=@_; |
my (undef,$part,$name)=split(/\./,$varname); |
my (undef,$part,$name)=split(/\./,$varname); |
Line 5160 sub metadata {
|
Line 5235 sub metadata {
|
$metaentry{':keys'}=join(',',keys %metathesekeys); |
$metaentry{':keys'}=join(',',keys %metathesekeys); |
&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri); |
&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri); |
$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys); |
$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys); |
&do_cache_new('meta',$uri,\%metaentry,60*60*24); |
&do_cache_new('meta',$uri,\%metaentry,60*60); |
# this is the end of "was not already recently cached |
# this is the end of "was not already recently cached |
} |
} |
return $metaentry{':'.$what}; |
return $metaentry{':'.$what}; |
Line 5256 sub get_slot {
|
Line 5331 sub get_slot {
|
$cdom=$env{'course.'.$courseid.'.domain'}; |
$cdom=$env{'course.'.$courseid.'.domain'}; |
$cnum=$env{'course.'.$courseid.'.num'}; |
$cnum=$env{'course.'.$courseid.'.num'}; |
} |
} |
my %slotinfo=&get('slots',[$which],$cdom,$cnum); |
my $key=join("\0",'slots',$cdom,$cnum,$which); |
&Apache::lonhomework::showhash(%slotinfo); |
my %slotinfo; |
my ($tmp)=keys(%slotinfo); |
if (exists($remembered{$key})) { |
if ($tmp=~/^error:/) { return (); } |
$slotinfo{$which} = $remembered{$key}; |
|
} else { |
|
%slotinfo=&get('slots',[$which],$cdom,$cnum); |
|
&Apache::lonhomework::showhash(%slotinfo); |
|
my ($tmp)=keys(%slotinfo); |
|
if ($tmp=~/^error:/) { return (); } |
|
$remembered{$key} = $slotinfo{$which}; |
|
} |
if (ref($slotinfo{$which}) eq 'HASH') { |
if (ref($slotinfo{$which}) eq 'HASH') { |
return %{$slotinfo{$which}}; |
return %{$slotinfo{$which}}; |
} |
} |
Line 5293 sub symbverify {
|
Line 5375 sub symbverify {
|
my $thisfn=$thisurl; |
my $thisfn=$thisurl; |
# wrapper not part of symbs |
# wrapper not part of symbs |
$thisfn=~s/^\/adm\/wrapper//; |
$thisfn=~s/^\/adm\/wrapper//; |
|
$thisfn=~s/^\/adm\/coursedocs\/showdoc\///; |
$thisfn=&declutter($thisfn); |
$thisfn=&declutter($thisfn); |
# direct jump to resource in page or to a sequence - will construct own symbs |
# direct jump to resource in page or to a sequence - will construct own symbs |
if ($thisfn=~/\.(page|sequence)$/) { return 1; } |
if ($thisfn=~/\.(page|sequence)$/) { return 1; } |
Line 5347 sub symbclean {
|
Line 5430 sub symbclean {
|
# remove wrapper |
# remove wrapper |
|
|
$symb=~s/(\_\_\_\d+\_\_\_)adm\/wrapper\/(res\/)*/$1/; |
$symb=~s/(\_\_\_\d+\_\_\_)adm\/wrapper\/(res\/)*/$1/; |
|
$symb=~s/(\_\_\_\d+\_\_\_)adm\/coursedocs\/showdoc\/(res\/)*/$1/; |
return $symb; |
return $symb; |
} |
} |
|
|
Line 5997 sub filelocation {
|
Line 6081 sub filelocation {
|
my ($dir,$file) = @_; |
my ($dir,$file) = @_; |
my $location; |
my $location; |
$file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces |
$file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces |
|
|
|
if ($file =~ m-^/adm/-) { |
|
$file=~s-^/adm/wrapper/-/-; |
|
$file=~s-^/adm/coursedocs/showdoc/-/-; |
|
} |
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:; |
Line 6036 sub hreflocation {
|
Line 6125 sub hreflocation {
|
my ($dir,$file)=@_; |
my ($dir,$file)=@_; |
unless (($file=~m-^http://-i) || ($file=~m-^/-)) { |
unless (($file=~m-^http://-i) || ($file=~m-^/-)) { |
$file=filelocation($dir,$file); |
$file=filelocation($dir,$file); |
|
} elsif ($file=~m-^/adm/-) { |
|
$file=~s-^/adm/wrapper/-/-; |
|
$file=~s-^/adm/coursedocs/showdoc/-/-; |
} |
} |
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--; |
Line 6079 sub declutter {
|
Line 6171 sub declutter {
|
if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); } |
if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); } |
$thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//; |
$thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//; |
$thisfn=~s/^\///; |
$thisfn=~s/^\///; |
|
$thisfn=~s|^adm/wrapper/||; |
|
$thisfn=~s|^adm/coursedocs/showdoc/||; |
$thisfn=~s/^res\///; |
$thisfn=~s/^res\///; |
$thisfn=~s/\?.+$//; |
$thisfn=~s/\?.+$//; |
return $thisfn; |
return $thisfn; |
Line 6091 sub clutter {
|
Line 6185 sub clutter {
|
unless ($thisfn=~/^\/(uploaded|editupload|adm|userfiles|ext|raw|priv|public)\//) { |
unless ($thisfn=~/^\/(uploaded|editupload|adm|userfiles|ext|raw|priv|public)\//) { |
$thisfn='/res'.$thisfn; |
$thisfn='/res'.$thisfn; |
} |
} |
|
if ($thisfn !~m|/adm|) { |
|
if ($thisfn =~ m|/ext/|) { |
|
$thisfn='/adm/wrapper'.$thisfn; |
|
} else { |
|
my ($ext) = ($thisfn =~ /\.(\w+)$/); |
|
my $embstyle=&Apache::loncommon::fileembstyle($ext); |
|
if ($embstyle eq 'ssi' |
|
|| ($embstyle eq 'hdn') |
|
|| ($embstyle eq 'rat') |
|
|| ($embstyle eq 'prv') |
|
|| ($embstyle eq 'ign')) { |
|
#do nothing with these |
|
} elsif (($embstyle eq 'img') |
|
|| ($embstyle eq 'emb') |
|
|| ($embstyle eq 'wrp')) { |
|
$thisfn='/adm/wrapper'.$thisfn; |
|
} elsif ($embstyle eq 'unk' |
|
&& $thisfn!~/\.(sequence|page)$/) { |
|
$thisfn='/adm/coursedocs/showdoc'.$thisfn; |
|
} else { |
|
&logthis("Got a blank emb style"); |
|
} |
|
} |
|
} |
return $thisfn; |
return $thisfn; |
} |
} |
|
|
Line 6234 BEGIN {
|
Line 6352 BEGIN {
|
} |
} |
close($config); |
close($config); |
# FIXME: dev server don't want this, production servers _do_ want this |
# FIXME: dev server don't want this, production servers _do_ want this |
&get_iphost(); |
#&get_iphost(); |
} |
} |
|
|
sub get_iphost { |
sub get_iphost { |
Line 6937 namesp ($udom and $uname are optional)
|
Line 7055 namesp ($udom and $uname are optional)
|
|
|
=item * |
=item * |
|
|
dump($namespace,$udom,$uname,$regexp) : |
dump($namespace,$udom,$uname,$regexp,$range) : |
dumps the complete (or key matching regexp) namespace into a hash |
dumps the complete (or key matching regexp) namespace into a hash |
($udom, $uname and $regexp are optional) |
($udom, $uname, $regexp, $range are optional) |
|
|
|
$range should be either an integer '100' (give me the first 100 |
|
matching records) |
|
or be two integers sperated by a - with no spaces |
|
'30-50' (give me the 30th through the 50th matching |
|
records) |
=item * |
=item * |
|
|
inc($namespace,$store,$udom,$uname) : increments $store in $namespace. |
inc($namespace,$store,$udom,$uname) : increments $store in $namespace. |