[LON-CAPA-cvs] cvs: loncom(version_2_11_X) /lonnet/perl lonnet.pm

[raeburn]

raeburn		Sun Apr  7 17:48:57 2013 EDT

  Modified files:              (Branch: version_2_11_X)
    /loncom/lonnet/perl	lonnet.pm 
  Log:
  - For 2.11
    - Backport 1.1180 (part).
  
  
Index: loncom/lonnet/perl/lonnet.pm
diff -u loncom/lonnet/perl/lonnet.pm:1.1172.2.21 loncom/lonnet/perl/lonnet.pm:1.1172.2.22
--- loncom/lonnet/perl/lonnet.pm:1.1172.2.21	Mon Mar 18 00:30:46 2013
+++ loncom/lonnet/perl/lonnet.pm	Sun Apr  7 17:48:57 2013
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.1172.2.21 2013/03/18 00:30:46 raeburn Exp $
+# $Id: lonnet.pm,v 1.1172.2.22 2013/04/07 17:48:57 raeburn Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -97,6 +97,7 @@
 use LONCAPA qw(:DEFAULT :match);
 use LONCAPA::Configuration;
 use LONCAPA::lonmetadata;
+use LONCAPA::Lond;
 
 use File::Copy;
 
@@ -4132,18 +4133,32 @@
 
 	    if (($domfilter eq '') ||
 		(&host_domain($tryserver) eq $domfilter)) {
-                my $rep = 
-                  &reply('courseiddump:'.&host_domain($tryserver).':'.
-                         $sincefilter.':'.&escape($descfilter).':'.
-                         &escape($instcodefilter).':'.&escape($ownerfilter).
-                         ':'.&escape($coursefilter).':'.&escape($typefilter).
-                         ':'.&escape($regexp_ok).':'.$as_hash.':'.
-                         &escape($selfenrollonly).':'.&escape($catfilter).':'.
-                         $showhidden.':'.$caller.':'.&escape($cloner).':'.
-                         &escape($cc_clone).':'.$cloneonly.':'.
-                         &escape($createdbefore).':'.&escape($createdafter).':'.
-                         &escape($creationcontext).':'.$domcloner,
-                         $tryserver);
+                my $rep;
+                if (grep { $_ eq $tryserver } &current_machine_ids()) {
+                    $rep = &LONCAPA::Lond::dump_course_id_handler(
+                        join(":", (&host_domain($tryserver), $sincefilter,
+                                &escape($descfilter), &escape($instcodefilter),
+                                &escape($ownerfilter), &escape($coursefilter),
+                                &escape($typefilter), &escape($regexp_ok),
+                                $as_hash, &escape($selfenrollonly),
+                                &escape($catfilter), $showhidden, $caller,
+                                &escape($cloner), &escape($cc_clone), $cloneonly,
+                                &escape($createdbefore), &escape($createdafter),
+                                &escape($creationcontext), $domcloner)));
+                } else {
+                    $rep = &reply('courseiddump:'.&host_domain($tryserver).':'.
+                             $sincefilter.':'.&escape($descfilter).':'.
+                             &escape($instcodefilter).':'.&escape($ownerfilter).
+                             ':'.&escape($coursefilter).':'.&escape($typefilter).
+                             ':'.&escape($regexp_ok).':'.$as_hash.':'.
+                             &escape($selfenrollonly).':'.&escape($catfilter).':'.
+                             $showhidden.':'.$caller.':'.&escape($cloner).':'.
+                             &escape($cc_clone).':'.$cloneonly.':'.
+                             &escape($createdbefore).':'.&escape($createdafter).':'.
+                             &escape($creationcontext).':'.$domcloner,
+                             $tryserver);
+                }
+
                 my @pairs=split(/\&/,$rep);
                 foreach my $item (@pairs) {
                     my ($key,$value)=split(/\=/,$item,2);
@@ -5389,12 +5404,36 @@
 
 # -------------------------------------------------------------- dump interface
 
+sub unserialize {
+    my ($rep, $escapedkeys) = @_;
+
+    return {} if $rep =~ /^error/;
+
+    my %returnhash=();
+    foreach my $item (split(/\&/,$rep)) {
+        my ($key, $value) = split(/=/, $item, 2);
+        $key = unescape($key) unless $escapedkeys;
+        next if $key =~ /^error: 2 /;
+        $returnhash{$key} = &thaw_unescape($value);
+    }
+    return \%returnhash;
+}
+
+# see Lond::dump_with_regexp
+# if $escapedkeys hash keys won't get unescaped.
 sub dump {
-    my ($namespace,$udomain,$uname,$regexp,$range)=@_;
+    my ($namespace,$udomain,$uname,$regexp,$range,$escapedkeys)=@_;
     if (!$udomain) { $udomain=$env{'user.domain'}; }
     if (!$uname) { $uname=$env{'user.name'}; }
     my $uhome=&homeserver($uname,$udomain);
 
+    my $reply;
+    if (grep { $_ eq $uhome } &current_machine_ids()) {
+        # user is hosted on this machine
+        $reply = LONCAPA::Lond::dump_with_regexp(join(':', ($udomain,
+                    $uname, $namespace, $regexp, $range)), $loncaparevs{$uhome});
+        return %{&unserialize($reply, $escapedkeys)};
+    }
     if ($regexp) {
 	$regexp=&escape($regexp);
     } else {
@@ -5406,7 +5445,7 @@
     if (!($rep =~ /^error/ )) {
 	foreach my $item (@pairs) {
 	    my ($key,$value)=split(/=/,$item,2);
-	    $key = &unescape($key);
+            $key = &unescape($key) unless ($escapedkeys);
 	    next if ($key =~ /^error: 2 /);
 	    $returnhash{$key}=&thaw_unescape($value);
 	}
@@ -5419,23 +5458,9 @@
 
 sub dumpstore {
    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);
-       next if ($key =~ /^error: 2 /);
-       $returnhash{$key}=&thaw_unescape($value);
-   }
-   return %returnhash;
+   # same as dump but keys must be escaped. They may contain colon separated
+   # lists of values that may themself contain colons (e.g. symbs).
+   return &dump($namespace, $udomain, $uname, $regexp, $range, 1);
 }
 
 # -------------------------------------------------------------- keys interface