--- loncom/lonnet/perl/lonnet.pm 2006/06/16 22:37:35 1.749
+++ loncom/lonnet/perl/lonnet.pm 2006/07/03 13:40:20 1.760.2.1
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.749 2006/06/16 22:37:35 raeburn Exp $
+# $Id: lonnet.pm,v 1.760.2.1 2006/07/03 13:40:20 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -281,6 +281,17 @@ sub critical {
return $answer;
}
+# ------------------------------------------- check if return value is an error
+
+sub error {
+ my ($result) = @_;
+ if ($result =~ /^(con_lost|no_such_host|error: (\d+) (.*))/) {
+ if ($2 == 2) { return undef; }
+ return $1;
+ }
+ return undef;
+}
+
# ------------------------------------------- Transfer profile into environment
sub transfer_profile_to_env {
@@ -1070,7 +1081,7 @@ sub currentversion {
sub subscribe {
my $fname=shift;
- if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return ''; }
+ if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg|grppg)$/) { return ''; }
$fname=~s/[\n\r]//g;
my $author=$fname;
$author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
@@ -1874,9 +1885,6 @@ sub get_course_adv_roles {
(!$nothide{$username.':'.$domain})) { next; }
if ($role eq 'cr') { next; }
my $key=&plaintext($role);
- if ($role =~ /^cr/) {
- $key=(split('/',$role))[3];
- }
if ($section) { $key.=' (Sec/Grp '.$section.')'; }
if ($returnhash{$key}) {
$returnhash{$key}.=','.$username.':'.$domain;
@@ -2922,23 +2930,25 @@ sub del {
# -------------------------------------------------------------- dump interface
sub dump {
- my ($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 (@pairs) {
- my ($key,$value)=split(/=/,$_,2);
- $returnhash{unescape($key)}=&thaw_unescape($value);
- }
- return %returnhash;
+ my ($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);
+ $key = &unescape($key);
+ next if ($key =~ /^error: 2 /);
+ $returnhash{$key}=&thaw_unescape($value);
+ }
+ return %returnhash;
}
# --------------------------------------------------------- dumpstore interface
@@ -4100,6 +4110,9 @@ sub devalidate_getgroups_cache {
sub plaintext {
my ($short,$type,$cid) = @_;
+ if ($short =~ /^cr/) {
+ return (split('/',$short))[-1];
+ }
if (!defined($cid)) {
$cid = $env{'request.course.id'};
}
@@ -4569,6 +4582,14 @@ sub is_locked {
}
}
+sub declutter_portfile {
+ my ($file) = @_;
+ &logthis("got $file");
+ $file =~ s-^(/portfolio/|portfolio/)-/-;
+ &logthis("ret $file");
+ return $file;
+}
+
# ------------------------------------------------------------- Mark as Read Only
sub mark_as_readonly {
@@ -4577,6 +4598,7 @@ sub mark_as_readonly {
my ($tmp)=keys(%current_permissions);
if ($tmp=~/^error:/) { undef(%current_permissions); }
foreach my $file (@{$files}) {
+ $file = &declutter_portfile($file);
push(@{$current_permissions{$file}},$what);
}
&put('file_permissions',\%current_permissions,$domain,$user);
@@ -4693,25 +4715,6 @@ sub get_access_controls {
return %access;
}
-sub parse_access_controls {
- my ($access_item) = @_;
- my %content;
- my $token;
- my $parser=HTML::TokeParser->new(\$access_item);
- while ($token=$parser->get_token) {
- if ($token->[0] eq 'S') {
- my $entry=$token->[1];
- if ($entry eq 'scope') {
- my $type = $token->[2]{'type'};
- } else {
- my $value=$parser->get_text('/'.$entry);
- $content{$entry}=$value;
- }
- }
- }
- return %content;
-}
-
sub modify_access_controls {
my ($file_name,$changes,$domain,$user)=@_;
my ($outcome,$deloutcome);
@@ -4817,7 +4820,7 @@ sub get_marked_as_readonly {
if (ref($value) eq "ARRAY"){
foreach my $stored_what (@{$value}) {
my $cmp2=$stored_what;
- if (ref($stored_what eq 'ARRAY')) {
+ if (ref($stored_what) eq 'ARRAY') {
$cmp2=join('',@{$stored_what});
}
if ($cmp1 eq $cmp2) {
@@ -4846,12 +4849,18 @@ sub get_marked_as_readonly_hash {
if (ref($value) eq "ARRAY"){
foreach my $stored_what (@{$value}) {
if (ref($stored_what) eq 'ARRAY') {
- if ($stored_what eq $what) {
- $readonly_files{$file_name} = 'locked';
- } elsif (!defined($what)) {
- $readonly_files{$file_name} = 'locked';
+ foreach my $lock_descriptor(@{$stored_what}) {
+ if ($lock_descriptor eq 'graded') {
+ $readonly_files{$file_name} = 'graded';
+ } elsif ($lock_descriptor eq 'handback') {
+ $readonly_files{$file_name} = 'handback';
+ } else {
+ if (!exists($readonly_files{$file_name})) {
+ $readonly_files{$file_name} = 'locked';
+ }
+ }
}
- }
+ }
}
}
}
@@ -4863,6 +4872,7 @@ sub unmark_as_readonly {
# unmarks $file_name (if $file_name is defined), or all files locked by $what
# for portfolio submissions, $what contains [$symb,$crsid]
my ($domain,$user,$what,$file_name,$group) = @_;
+ $file_name = &declutter_portfile($file_name);
my $symb_crs = $what;
if (ref($what)) { $symb_crs=join('',@$what); }
my %current_permissions = &dump('file_permissions',$domain,$user,$group);
@@ -4870,7 +4880,8 @@ sub unmark_as_readonly {
if ($tmp=~/^error:/) { undef(%current_permissions); }
my @readonly_files = &get_marked_as_readonly($domain,$user,$what,$group);
foreach my $file (@readonly_files) {
- if (defined($file_name) && ($file_name ne $file)) { next; }
+ my $clean_file = &declutter_portfile($file);
+ if (defined($file_name) && ($file_name ne $clean_file)) { next; }
my $current_locks = $current_permissions{$file};
my @new_locks;
my @del_keys;
@@ -6911,7 +6922,7 @@ BEGIN {
}
close($config);
# FIXME: dev server don't want this, production servers _do_ want this
- #&get_iphost();
+ &get_iphost();
}
sub get_iphost {