[LON-CAPA-cvs] cvs: loncom / lond /lonnet/perl lonnet.pm
raeburn
raeburn@source.lon-capa.org
Mon, 10 Aug 2009 23:32:36 -0000
This is a MIME encoded message
--raeburn1249947156
Content-Type: text/plain
raeburn Mon Aug 10 23:32:36 2009 EDT
Modified files:
/loncom lond
/loncom/lonnet/perl lonnet.pm
Log:
Similar functionality to that provided by newput, dump and del for user .db files provided by newputdom, dumpdom and deldom for .db files at the domain level.
New routines: &dump_dom(), &newput_dom() and &del_dom() in lonnet.pm
send calls via lonc/lond which are handled on the lond side by:
&newput_domain_handler(), &dump_dom_with_regexp() and &delete_domain_entry()
--raeburn1249947156
Content-Type: text/plain
Content-Disposition: attachment; filename="raeburn-20090810233236.txt"
Index: loncom/lond
diff -u loncom/lond:1.419 loncom/lond:1.420
--- loncom/lond:1.419 Fri Jul 31 02:20:12 2009
+++ loncom/lond Mon Aug 10 23:32:26 2009
@@ -2,7 +2,7 @@
# The LearningOnline Network
# lond "LON Daemon" Server (port "LOND" 5663)
#
-# $Id: lond,v 1.419 2009/07/31 02:20:12 raeburn Exp $
+# $Id: lond,v 1.420 2009/08/10 23:32:26 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -59,7 +59,7 @@
my $status='';
my $lastlog='';
-my $VERSION='$Revision: 1.419 $'; #' stupid emacs
+my $VERSION='$Revision: 1.420 $'; #' stupid emacs
my $remoteVERSION;
my $currenthostid="default";
my $currentdomainid;
@@ -4052,6 +4052,60 @@
}
®ister_handler("putdom", \&put_domain_handler, 0, 1, 0);
+#
+# Puts a piece of new data in a namespace db file at the domain level
+# returns error if key already exists
+#
+# Parameters:
+# $cmd - The command that got us here.
+# $tail - Tail of the command (remaining parameters).
+# $client - File descriptor connected to client.
+# Returns
+# 0 - Requested to exit, caller should shut down.
+# 1 - Continue processing.
+# Side effects:
+# reply is written to $client.
+#
+sub newput_domain_handler {
+ my ($cmd, $tail, $client) = @_;
+
+ my $userinput = "$cmd:$tail";
+
+ my ($udom,$namespace,$what) =split(/:/,$tail,3);
+ chomp($what);
+ my $hashref = &tie_domain_hash($udom, "$namespace", &GDBM_WRCREAT(),
+ "N", $what);
+ if(!$hashref) {
+ &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
+ "while attempting newputdom\n", $userinput);
+ return 1;
+ }
+
+ my @pairs=split(/\&/,$what);
+ foreach my $pair (@pairs) {
+ my ($key,$value)=split(/=/,$pair);
+ if (exists($hashref->{$key})) {
+ &Failure($client, "key_exists: ".$key."\n",$userinput);
+ return 1;
+ }
+ }
+
+ foreach my $pair (@pairs) {
+ my ($key,$value)=split(/=/,$pair);
+ $hashref->{$key}=$value;
+ }
+
+ if (&untie_domain_hash($hashref)) {
+ &Reply( $client, "ok\n", $userinput);
+ } else {
+ &Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
+ "while attempting newputdom\n",
+ $userinput);
+ }
+ return 1;
+}
+®ister_handler("newputdom", \&newput_domain_handler, 0, 1, 0);
+
# Unencrypted get from the namespace database file at the domain level.
# This function retrieves a keyed item from a specific named database in the
# domain directory.
@@ -4101,6 +4155,49 @@
}
®ister_handler("getdom", \&get_domain_handler, 0, 1, 0);
+#
+# Deletes a key in a user profile database.
+#
+# Parameters:
+# $cmd - Command keyword (deldom).
+# $tail - Command tail. IN this case a colon
+# separated list containing:
+# the domain to which the database file belongs;
+# the namespace (name of the database file);
+# & separated list of keys to delete.
+# $client - File open on client socket.
+# Returns:
+# 1 - Continue processing
+# 0 - Exit server.
+#
+#
+sub delete_domain_entry {
+ my ($cmd, $tail, $client) = @_;
+
+ my $userinput = "cmd:$tail";
+
+ my ($udom,$namespace,$what) = split(/:/,$tail);
+ chomp($what);
+ my $hashref = &tie_domain_hash($udom, $namespace, &GDBM_WRCREAT(),
+ "D",$what);
+ if ($hashref) {
+ my @keys=split(/\&/,$what);
+ foreach my $key (@keys) {
+ delete($hashref->{$key});
+ }
+ if (&untie_user_hash($hashref)) {
+ &Reply($client, "ok\n", $userinput);
+ } else {
+ &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
+ "while attempting deldom\n", $userinput);
+ }
+ } else {
+ &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
+ "while attempting deldom\n", $userinput);
+ }
+ return 1;
+}
+®ister_handler("deldom", \&delete_domain_entry, 0, 1, 0);
#
# Puts an id to a domains id database.
@@ -4199,6 +4296,60 @@
}
®ister_handler("idget", \&get_id_handler, 0, 1, 0);
+sub dump_dom_with_regexp {
+ my ($cmd, $tail, $client) = @_;
+ my $userinput = "$cmd:$tail";
+ my ($udom,$namespace,$regexp,$range)=split(/:/,$tail);
+ if (defined($regexp)) {
+ $regexp=&unescape($regexp);
+ } else {
+ $regexp='.';
+ }
+ my ($start,$end);
+ if (defined($range)) {
+ if ($range =~/^(\d+)\-(\d+)$/) {
+ ($start,$end) = ($1,$2);
+ } elsif ($range =~/^(\d+)$/) {
+ ($start,$end) = (0,$1);
+ } else {
+ undef($range);
+ }
+ }
+ my $hashref = &tie_domain_hash($udom, $namespace, &GDBM_READER());
+ if ($hashref) {
+ my $qresult='';
+ my $count=0;
+ while (my ($key,$value) = each(%$hashref)) {
+ if ($regexp eq '.') {
+ $count++;
+ if (defined($range) && $count >= $end) { last; }
+ if (defined($range) && $count < $start) { next; }
+ $qresult.=$key.'='.$value.'&';
+ } else {
+ my $unescapeKey = &unescape($key);
+ if (eval('$unescapeKey=~/$regexp/')) {
+ $count++;
+ if (defined($range) && $count >= $end) { last; }
+ if (defined($range) && $count < $start) { next; }
+ $qresult.="$key=$value&";
+ }
+ }
+ }
+ if (&untie_user_hash($hashref)) {
+ chop($qresult);
+ &Reply($client, \$qresult, $userinput);
+ } else {
+ &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
+ "while attempting dump\n", $userinput);
+ }
+ } else {
+ &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
+ "while attempting dump\n", $userinput);
+ }
+ return 1;
+}
+®ister_handler("dumpdom", \&dump_dom_with_regexp, 0, 1, 0);
+
#
# Puts broadcast e-mail sent by Domain Coordinator in nohist_dcmail database
#
Index: loncom/lonnet/perl/lonnet.pm
diff -u loncom/lonnet/perl/lonnet.pm:1.1011 loncom/lonnet/perl/lonnet.pm:1.1012
--- loncom/lonnet/perl/lonnet.pm:1.1011 Sat Aug 8 19:55:24 2009
+++ loncom/lonnet/perl/lonnet.pm Mon Aug 10 23:32:35 2009
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.1011 2009/08/08 19:55:24 raeburn Exp $
+# $Id: lonnet.pm,v 1.1012 2009/08/10 23:32:35 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -958,6 +958,43 @@
}
}
+# ------------------------------------------------ dump from domain db files
+
+sub dump_dom {
+ my ($namespace,$udom,$uhome,$regexp,$range)=@_;
+ if (!$udom) {
+ $udom=$env{'user.domain'};
+ if (defined(&domain($udom,'primary'))) {
+ $uhome=&domain($udom,'primary');
+ } else {
+ undef($uhome);
+ }
+ } else {
+ if (!$uhome) {
+ if (defined(&domain($udom,'primary'))) {
+ $uhome=&domain($udom,'primary');
+ }
+ }
+ }
+ my %returnhash;
+ if ($udom && $uhome && ($uhome ne 'no_host')) {
+ if ($regexp) {
+ $regexp=&escape($regexp);
+ } else {
+ $regexp='.';
+ }
+ my $rep=&reply("dumpdom:$udom:$namespace:$regexp:$range",$uhome);
+ my @pairs=split(/\&/,$rep);
+ 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;
+}
+
# ------------------------------------------- get items from domain db files
sub get_dom {
@@ -1032,6 +1069,70 @@
}
}
+# -------------------------------------- newput for items in domain db files
+
+sub newput_dom {
+ my ($namespace,$storehash,$udom,$uhome) = @_;
+ my $result;
+ if (!$udom) {
+ $udom=$env{'user.domain'};
+ if (defined(&domain($udom,'primary'))) {
+ $uhome=&domain($udom,'primary');
+ } else {
+ undef($uhome);
+ }
+ } else {
+ if (!$uhome) {
+ if (defined(&domain($udom,'primary'))) {
+ $uhome=&domain($udom,'primary');
+ }
+ }
+ }
+ if ($udom && $uhome && ($uhome ne 'no_host')) {
+ my $items='';
+ if (ref($storehash) eq 'HASH') {
+ foreach my $key (keys(%$storehash)) {
+ $items.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
+ }
+ $items=~s/\&$//;
+ $result = &reply("newputdom:$udom:$namespace:$items",$uhome);
+ }
+ } else {
+ &logthis("put_dom failed - no homeserver and/or domain");
+ }
+ return $result;
+}
+
+sub del_dom {
+ my ($namespace,$storearr,$udom,$uhome)=@_;
+ if (ref($storearr) eq 'ARRAY') {
+ my $items='';
+ foreach my $item (@$storearr) {
+ $items.=&escape($item).'&';
+ }
+ $items=~s/\&$//;
+ if (!$udom) {
+ $udom=$env{'user.domain'};
+ if (defined(&domain($udom,'primary'))) {
+ $uhome=&domain($udom,'primary');
+ } else {
+ undef($uhome);
+ }
+ } else {
+ if (!$uhome) {
+ if (defined(&domain($udom,'primary'))) {
+ $uhome=&domain($udom,'primary');
+ }
+ }
+ }
+ if ($udom && $uhome && ($uhome ne 'no_host')) {
+ return &reply("deldom:$udom:$namespace:$items",$uhome);
+ } else {
+ &logthis("del_dom failed - no homeserver and/or domain");
+ }
+ }
+}
+
sub retrieve_inst_usertypes {
my ($udom) = @_;
my (%returnhash,@order);
--raeburn1249947156--