[LON-CAPA-cvs] cvs: loncom /cgi listdomconfig.pl loncgi.pm

[raeburn]

raeburn		Mon Aug  1 15:19:06 2016 EDT

  Modified files:              
    /loncom/cgi	listdomconfig.pl loncgi.pm 
  Log:
  - listdomconfig.pl can be called with a query string to return domain
    configuration in serialized form (format=raw).   
  
  
Index: loncom/cgi/listdomconfig.pl
diff -u loncom/cgi/listdomconfig.pl:1.1 loncom/cgi/listdomconfig.pl:1.2
--- loncom/cgi/listdomconfig.pl:1.1	Fri Oct 21 20:23:36 2011
+++ loncom/cgi/listdomconfig.pl	Mon Aug  1 15:19:05 2016
@@ -1,7 +1,7 @@
 #!/usr/bin/perl
 $|=1;
 # Domain Configuration Dump
-# $Id: listdomconfig.pl,v 1.1 2011/10/21 20:23:36 raeburn Exp $
+# $Id: listdomconfig.pl,v 1.2 2016/08/01 15:19:05 raeburn Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -95,12 +95,29 @@
     }
     &LONCAPA::loncgi::check_cookie_and_load_env();
     &Apache::lonlocal::get_language_handle();
+    my (%gets,$format);
+    &LONCAPA::loncgi::cgi_getitems($ENV{'QUERY_STRING'},\%gets,['format','primary']);
+    if (ref($gets{'format'}) eq 'ARRAY') {
+        $format = $gets{'format'}->[0];
+    }
     if ($allowed ne '') {
         my @okdoms;
         unless ($allowed == 1) {
             @okdoms = split(/\&/,$allowed);
         }
-        my @hosts = &Apache::lonnet::current_machine_ids();
+        my @hosts;
+        if (ref($gets{'primary'}) eq 'ARRAY') {
+            my @posshosts = &Apache::lonnet::current_machine_ids();
+            foreach my $prim (@{$gets{'primary'}}) {
+                if (grep(/^\Q$prim\E$/, at posshosts)) {
+                    unless (grep(/^\Q$prim\E$/, at hosts)) {
+                        push(@hosts,$prim);
+                    }
+                }
+            }
+        } else {
+            @hosts = &Apache::lonnet::current_machine_ids();
+        }
         my $numshown = 0;
         my $numnonprim = 0;
         foreach my $lonhost (@hosts) {
@@ -110,9 +127,11 @@
             }
             my $prim_id = &Apache::lonnet::domain($dom,'primary');
             if (($prim_id ne '') && (grep(/^\Q$prim_id\E$/, at hosts))) {
-                my $domdesc = &Apache::lonnet::domain($dom);
-                print &mt('Domain configuration for [_1]',"$domdesc ($dom)")."\n\n";
-                &show_config($dom);
+                unless ($format eq 'raw') {
+                    my $domdesc = &Apache::lonnet::domain($dom);
+                    print &mt('Domain configuration for [_1]',"$domdesc ($dom)")."\n\n";
+                }
+                &show_config($dom,$format);
                 print "\n";
                 $numshown ++;
             } else {
@@ -121,13 +140,19 @@
         }
         if (!$numshown) {
             if ($numnonprim) {
-                print &mt('This server is not a primary library server')."\n";
+                unless ($format eq 'raw') {
+                    print &mt('This server is not a primary library server')."\n";
+                }
             } else {
-                print &mt("You do not have access rights to view domain configuration for domain(s) hosted on this server.")."\n";
+                unless ($format eq 'raw') { 
+                    print &mt("You do not have access rights to view domain configuration for domain(s) hosted on this server.")."\n";
+                }
             }
         }
     } else {
-        &LONCAPA::lonauthcgi::unauthorized_msg('domconf');
+        unless ($format eq 'raw') {
+            &LONCAPA::lonauthcgi::unauthorized_msg('domconf');
+        }
     }
 }
 
@@ -151,21 +176,30 @@
 #############################################
 
 sub show_config {
-    my ($dom) = @_;
+    my ($dom,$format) = @_;
     my $lonusersdir = $Apache::lonnet::perlvar{'lonUsersDir'};
     my $fname = $lonusersdir.'/'.$dom.'/configuration.db';
     my $dbref=&LONCAPA::locking_hash_tie($fname,&GDBM_READER());
     if (ref($dbref) eq 'HASH') {
+        my $output; 
         foreach my $key (sort(keys(%{$dbref}))) {
             my $value = $dbref->{$key};  
-            if ($value =~ s/^__FROZEN__//) {
-                $value = thaw(&unescape($value));
+            if ($format eq 'raw') {
+                $output .= "$key=$value".'&';    
+            } else {
+                if ($value =~ s/^__FROZEN__//) {
+                    $value = thaw(&unescape($value));
+                }
+                $key = &unescape($key);
+                $value = &unescape($value) if (!ref($value));
+                print "$key = ".(ref($value)?Dumper($value):$value)."\n";
             }
-            $key = &unescape($key);
-            $value = &unescape($value) if (!ref($value));
-            print "$key = ".(ref($value)?Dumper($value):$value)."\n";
         }
         &LONCAPA::locking_hash_untie($dbref);
+        if ($format eq 'raw') {
+            $output .=~ s/\&$//;
+            print $output;
+        } 
     }
     return;
 }
Index: loncom/cgi/loncgi.pm
diff -u loncom/cgi/loncgi.pm:1.14 loncom/cgi/loncgi.pm:1.15
--- loncom/cgi/loncgi.pm:1.14	Tue Oct 14 19:54:00 2014
+++ loncom/cgi/loncgi.pm	Mon Aug  1 15:19:05 2016
@@ -1,7 +1,7 @@
 #
 # LON-CAPA helpers for cgi-bin scripts
 #
-# $Id: loncgi.pm,v 1.14 2014/10/14 19:54:00 raeburn Exp $
+# $Id: loncgi.pm,v 1.15 2016/08/01 15:19:05 raeburn Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -200,7 +200,9 @@
 
 =cgi_getitems()
 
-Inputs: $query (the CGI query string), and $getitems, a reference to a hash 
+Inputs: $query - the CGI query string (required)
+        $getitems - reference to a hash (required)
+        $possname - permitted names of keys (optional)
 
 Returns: nothing
 
@@ -213,10 +215,13 @@
 #############################################
 #############################################
 sub cgi_getitems {
-    my ($query,$getitems)= @_;
+    my ($query,$getitems,$possnames)= @_;
     foreach (split(/&/,$query)) {
         my ($name, $value) = split(/=/,$_);
         $name = &unescape($name);
+        if (ref($possnames) eq 'ARRAY') {
+            next unless (grep(/^\Q$name\E$/,@{$possnames}));
+        }
         $value =~ tr/+/ /;
         $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
         push(@{$$getitems{$name}},$value);