--- loncom/lonnet/perl/lonnet.pm 2006/06/22 13:06:50 1.752 +++ loncom/lonnet/perl/lonnet.pm 2006/06/26 18:56:03 1.758 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.752 2006/06/22 13:06:50 raeburn Exp $ +# $Id: lonnet.pm,v 1.758 2006/06/26 18:56:03 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 { @@ -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'}; } @@ -4693,67 +4706,6 @@ sub get_access_controls { return %access; } -sub parse_access_controls { - my ($access_item) = @_; - my %content; - my $role_id; - my $user; - my $usercount; - 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'}; - if (($type eq 'course') || ($type eq 'group')) { - %{$content{'roles'}} = (); - } - } elsif ($entry eq 'roles') { - $role_id = $token->[2]{id}; - %{$content{$entry}{$role_id}} = ( - role => [], - access => [], - section => [], - group => [], - ); - } elsif ($entry eq 'users') { - %{$content{'users'}} = (); - $usercount = 0; - } elsif ($entry eq 'user') { - $user = ''; - } else { - my $value=$parser->get_text('/'.$entry); - if ($entry eq 'uname') { - $user = $value; - } elsif ($entry eq 'udom') { - $user .= ':'.$value; - $content{'users'}{$user} = $usercount; - } elsif ($entry eq 'role' || - $entry eq 'access' || - $entry eq 'section' || - $entry eq 'group') { - if ($role_id ne '') { - push(@{$content{'roles'}{$role_id}{$entry}},$value); - } - } elsif ($entry eq 'dom') { - push(@{$content{$entry}},$value); - } else { - $content{$entry}=$value; - } - } - } elsif ($token->[0] eq 'E') { - if ($token->[1] eq 'user') { - $user = ''; - $usercount ++; - } elsif ($token->[1] eq 'roles') { - $role_id = ''; - } - } - } - return %content; -} - sub modify_access_controls { my ($file_name,$changes,$domain,$user)=@_; my ($outcome,$deloutcome);