[LON-CAPA-cvs] cvs: loncom / lond /debugging_tools rebuild_db_from_hist.pl /homework grades.pm /interface loncreateuser.pm lonparmset.pm lonpreferences.pm lonquickgrades.pm /lonnet/perl lonnet.pm /metadata_database searchcat.pl

raeburn raeburn at source.lon-capa.org
Sun Jan 31 16:26:02 EST 2016


raeburn		Sun Jan 31 21:26:02 2016 EDT

  Modified files:              
    /loncom/interface	lonpreferences.pm loncreateuser.pm 
                     	lonquickgrades.pm lonparmset.pm 
    /loncom/homework	grades.pm 
    /loncom/metadata_database	searchcat.pl 
    /loncom	lond 
    /loncom/lonnet/perl	lonnet.pm 
    /loncom/debugging_tools	rebuild_db_from_hist.pl 
  Log:
  - Score upload form supports identification of a user based on clicker ID,
    for Course Coordinators who prefer not to use LON-CAPA's in-built 
    "Process Clicker" utility. 
  - clickers.db file on a library server contains key = value pairs, where key
    is (escaped) clicker ID, and value is (escaped) comma-separated list of
    usernames who registered that particular clicker ID.
  - bi-nightly run of searchcat.pl will update clickers.db file.
  
  
-------------- next part --------------
Index: loncom/interface/lonpreferences.pm
diff -u loncom/interface/lonpreferences.pm:1.217 loncom/interface/lonpreferences.pm:1.218
--- loncom/interface/lonpreferences.pm:1.217	Wed Jan 27 00:24:09 2016
+++ loncom/interface/lonpreferences.pm	Sun Jan 31 21:25:37 2016
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # Preferences
 #
-# $Id: lonpreferences.pm,v 1.217 2016/01/27 00:24:09 raeburn Exp $
+# $Id: lonpreferences.pm,v 1.218 2016/01/31 21:25:37 raeburn Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -713,16 +713,51 @@
     my $r = shift;
     my $user       = $env{'user.name'};
     my $domain     = $env{'user.domain'};
+    my $uhome      = $env{'user.home'};
     my $newclickers  = $env{'form.clickers'};
+    my $message;
     $newclickers=~s/[^\w\:\-]+/\,/gs;
     $newclickers=~tr/a-z/A-Z/;
     $newclickers=~s/[\:\-]+/\-/g;
     $newclickers=~s/\,+/\,/g;
     $newclickers=~s/^\,//;
     $newclickers=~s/\,$//;
-    &Apache::lonnet::put('environment',{'clickers' => $newclickers});
-    &Apache::lonnet::appenv({'environment.clickers' => $newclickers});
-    my $message=&Apache::lonhtmlcommon::confirm_success(&mt('Registering clickers: [_1]',$newclickers));
+    my @oldclickers = split(/,/,$env{'environment.clickers'});
+    my @newclickers = split(/,/,$newclickers);
+    my %newuniq;
+    map { $newuniq{$_} = 1; }  @newclickers;
+    @newclickers = sort(keys(%newuniq));
+    my @differences = &Apache::loncommon::compare_arrays(\@oldclickers,\@newclickers);
+    if (@differences) {
+        my $putres = &Apache::lonnet::put('environment',{'clickers' => $newclickers});
+        if ($putres eq 'ok') {
+            my @adds = ();
+            my @dels = ();
+            foreach my $item (@differences) {
+                if (grep(/^\Q$item\E$/, at newclickers)) {
+                    push(@adds,$item);
+                } else {
+                    push(@dels,$item);
+                }
+            }
+            if (@dels) {
+                 my %delclicker;
+                 map { $delclicker{$_} = $user; } @dels;
+                 my $putresult = &Apache::lonnet::iddel($domain,\%delclicker,$uhome,'clickers');
+            }
+            if (@adds) {
+                 my %addclicker;
+                 map { $addclicker{$_} = $user; } @adds;
+                 my $putresult = &Apache::lonnet::updateclickers($domain,'add',\%addclicker,$uhome,1);
+            }
+            &Apache::lonnet::appenv({'environment.clickers' => $newclickers});
+            $message=&Apache::lonhtmlcommon::confirm_success(&mt('Registering clickers: [_1]',$newclickers));
+        } else {
+            $message=&Apache::lonhtmlcommon::confirm_success(&mt('Error saving clicker ID').1);
+        }
+    } else {
+        $message='<span class="LC_info">'.&mt('Clicker information unchanged').'</span>';
+    }
     $message=&Apache::loncommon::confirmwrapper($message);
     &print_main_menu($r, $message);
 }
Index: loncom/interface/loncreateuser.pm
diff -u loncom/interface/loncreateuser.pm:1.406 loncom/interface/loncreateuser.pm:1.407
--- loncom/interface/loncreateuser.pm:1.406	Fri Sep  4 18:07:07 2015
+++ loncom/interface/loncreateuser.pm	Sun Jan 31 21:25:38 2016
@@ -1,7 +1,7 @@
 # The LearningOnline Network with CAPA
 # Create a user
 #
-# $Id: loncreateuser.pm,v 1.406 2015/09/04 18:07:07 raeburn Exp $
+# $Id: loncreateuser.pm,v 1.407 2016/01/31 21:25:38 raeburn Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -3110,7 +3110,7 @@
                                   \%newsettingstext);
                 if ($env{'form.cid'} ne $userenv{'id'}) {
                     &Apache::lonnet::idput($env{'form.ccdomain'},
-                         ($env{'form.ccuname'} => $env{'form.cid'}));
+                         {$env{'form.ccuname'} => $env{'form.cid'}},$uhome,'ids');
                     if (($recurseid) &&
                         (&Apache::lonnet::allowed('mau',$env{'form.ccdomain'}))) {
                         my $idresult = 
Index: loncom/interface/lonquickgrades.pm
diff -u loncom/interface/lonquickgrades.pm:1.107 loncom/interface/lonquickgrades.pm:1.108
--- loncom/interface/lonquickgrades.pm:1.107	Mon Mar 30 22:29:24 2015
+++ loncom/interface/lonquickgrades.pm	Sun Jan 31 21:25:38 2016
@@ -1,7 +1,7 @@
 # The LearningOnline Network with CAPA
 # Quick Student Grades Display
 #
-# $Id: lonquickgrades.pm,v 1.107 2015/03/30 22:29:24 raeburn Exp $
+# $Id: lonquickgrades.pm,v 1.108 2016/01/31 21:25:38 raeburn Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -177,7 +177,7 @@
         if ($env{'form.udom'}) { $udom=$env{'form.udom'}; }
         if ($env{'form.id'}) { $stdid=$env{'form.id'}; }
         if (($stdid) && ($udom)) {
-            $uname=(&Apache::lonnet::idget($udom,$stdid))[1];
+            $uname=(&Apache::lonnet::idget($udom,[$stdid],'ids'))[1];
         }
         if (($stdid) && (!$uname)) {
             $r->print('<p><span class="LC_warning">'.&mt("Unknown Student/Employee ID: [_1]",$stdid).'</span></p>');
Index: loncom/interface/lonparmset.pm
diff -u loncom/interface/lonparmset.pm:1.554 loncom/interface/lonparmset.pm:1.555
--- loncom/interface/lonparmset.pm:1.554	Sun Sep 13 21:48:05 2015
+++ loncom/interface/lonparmset.pm	Sun Jan 31 21:25:38 2016
@@ -1,7 +1,7 @@
 # The LearningOnline Network with CAPA
 # Handler to set parameters for assessments
 #
-# $Id: lonparmset.pm,v 1.554 2015/09/13 21:48:05 raeburn Exp $
+# $Id: lonparmset.pm,v 1.555 2016/01/31 21:25:38 raeburn Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -2291,7 +2291,7 @@
 
     my $id=$env{'form.id'};
     if (($id) && ($udom)) {
-        $uname=(&Apache::lonnet::idget($udom,$id))[1];
+        $uname=(&Apache::lonnet::idget($udom,[$id],'ids'))[1];
         if ($uname) {
             $id='';
         } else {
Index: loncom/homework/grades.pm
diff -u loncom/homework/grades.pm:1.736 loncom/homework/grades.pm:1.737
--- loncom/homework/grades.pm:1.736	Tue Jun  9 21:22:48 2015
+++ loncom/homework/grades.pm	Sun Jan 31 21:25:42 2016
@@ -1,7 +1,7 @@
 # The LearningOnline Network with CAPA
 # The LON-CAPA Grading handler
 #
-# $Id: grades.pm,v 1.736 2015/06/09 21:22:48 damieng Exp $
+# $Id: grades.pm,v 1.737 2016/01/31 21:25:42 raeburn Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -4157,6 +4157,7 @@
     }
 
     my @fields=(['ID','Student/Employee ID'],
+                ['clicker','Clicker ID'],
 		['username','Student Username'],
 		['domain','Student Domain']);
     my (undef,undef,$url) = &Apache::lonnet::decode_symb($symb);
@@ -4352,13 +4353,45 @@
 	if (!$username) {
 	    my $id=$entries{$fields{'ID'}};
 	    $id=~s/\s//g;
-	    my %ids=&Apache::lonnet::idget($domain,$id);
-	    $username=$ids{$id};
+            if ($id ne '') {
+	        my %ids=&Apache::lonnet::idget($domain,[$id]);
+	        $username=$ids{$id};
+            } else {
+                if ($entries{$fields{'clicker'}}) {
+                    my $clicker = $entries{$fields{'clicker'}};
+                    $clicker=~s/\s//g;
+                    if ($clicker ne '') {
+                        my %clickers = &Apache::lonnet::idget($domain,[$clicker],'clickers');
+                        if ($clickers{$clicker} ne '') {  
+                            my $match = 0;
+                            my @inclass;
+                            foreach my $poss (split(/,/,$clickers{$clicker})) {
+                                if (exists($$classlist{"$poss:$domain"})) {
+                                    $username = $poss;
+                                    push(@inclass,$poss);
+                                    $match ++;
+                                    
+                                }
+                            }
+                            if ($match > 1) {
+                                undef($username); 
+                                $request->print('<p class="LC_warning">'.
+                                                &mt('Score not saved for clicker: [_1] (matched multiple usernames: [_2])',
+                                                $clicker,join(', ', at inclass)).'</p>');
+                            }
+                        }
+                    }
+                }
+            }
 	}
 	if (!exists($$classlist{"$username:$domain"})) {
 	    my $id=$entries{$fields{'ID'}};
 	    $id=~s/\s//g;
-	    if ($id) {
+            my $clicker = $entries{$fields{'clicker'}};
+            $clicker=~s/\s//g;
+            if ($clicker) {
+                push(@skipped,"$clicker:$domain");
+	    } elsif ($id) {
 		push(@skipped,"$id:$domain");
 	    } else {
 		push(@skipped,"$username:$domain");
Index: loncom/metadata_database/searchcat.pl
diff -u loncom/metadata_database/searchcat.pl:1.83 loncom/metadata_database/searchcat.pl:1.84
--- loncom/metadata_database/searchcat.pl:1.83	Wed Jan 27 22:22:59 2016
+++ loncom/metadata_database/searchcat.pl	Sun Jan 31 21:25:49 2016
@@ -2,7 +2,7 @@
 # The LearningOnline Network
 # searchcat.pl "Search Catalog" batch script
 #
-# $Id: searchcat.pl,v 1.83 2016/01/27 22:22:59 raeburn Exp $
+# $Id: searchcat.pl,v 1.84 2016/01/31 21:25:49 raeburn Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -273,19 +273,51 @@
             &portfolio_logging(%portmetalog);
         }
     }
-    my (%names_by_id,,%ids_by_name,%idstodelete,%idstoadd,%duplicates);
+    my %duplicates;
+    my %names_by_id = (
+                          id       => {},
+                          clickers => {},
+                      );
+    my %ids_by_name = (
+                          id       => {},
+                          clickers => {},
+                      );
+    my %idstodelete = (
+                          id       => {},
+                          clickers => {}, 
+                      );
+    my %idstoadd    = (
+                          id       => {},
+                          clickers => {},
+                      );
+    my %namespace  = (
+                         id       => 'ids',
+                         clickers => 'clickers',
+                     );
+    my %idtext = (
+                     id       => 'employee/student IDs',
+                     clickers => 'clicker IDs',
+                 );
     unless ($simulate || $oneuser) {
-        my $idshashref;
-        $idshashref = &tie_domain_hash($dom, "ids", &GDBM_WRCREAT());
-        if (ref($idshashref) eq 'HASH') {
-            %names_by_id = %{$idshashref};
-            while (my ($id,$uname) = each(%{$idshashref}) ) {
-                $id = &unescape($id);
-                $uname = &unescape($uname); 
-                $names_by_id{$id} = $uname;
-                push(@{$ids_by_name{$uname}},$id);
+        foreach my $key ('id','clickers') {
+            my $hashref = &tie_domain_hash($dom,$namespace{$key},&GDBM_WRCREAT());
+            if (ref($hashref) eq 'HASH') {
+                while (my ($id,$unamestr) = each(%{$hashref}) ) {
+                    $id = &unescape($id);
+                    $unamestr = &unescape($unamestr);
+                    if ($key eq 'clickers') {
+                        my @unames = split(/,/,$unamestr);
+                        foreach my $uname (@unames) {
+                            push(@{$ids_by_name{$key}{$uname}},$id);
+                        }
+                        $names_by_id{$key}{$id} = $unamestr;
+                    } else {
+                        $names_by_id{$key}{$id} = $unamestr;
+                        push(@{$ids_by_name{$key}{$unamestr}},$id);
+                    }
+                }
+                &untie_domain_hash($hashref);
             }
-            &untie_domain_hash($idshashref);
         }
     }
     # Update allusers
@@ -293,36 +325,55 @@
         next if (exists($courses{$dom.'_'.$uname}));
         my %userdata = 
             &Apache::lonnet::get('environment',['firstname','lastname',
-                'middlename','generation','id','permanentemail'],$dom,$uname);
+                'middlename','generation','id','permanentemail','clickers'],
+                                 $dom,$uname);
         unless ($simulate || $oneuser) {
-            my $addid;
-            if ($userdata{'id'} ne '') {
-                $addid = $userdata{'id'};
-                $addid=~tr/A-Z/a-z/;
-            }
-            if (exists($ids_by_name{$uname})) {
-                if (ref($ids_by_name{$uname}) eq 'ARRAY') {
-                    if (scalar(@{$ids_by_name{$uname}}) > 1) {
-                        &log(0,"Multiple employee/student IDs found in ids.db for $uname:$dom -- ".join(', ',@{$ids_by_name{$uname}}));
-                    }
-                    foreach my $id (@{$ids_by_name{$uname}}) {
-                        if ($id eq $userdata{'id'}) {
-                            undef($addid);
-                        } else { 
-                            $idstodelete{$id} = $uname;
+            foreach my $key ('id','clickers') {
+                my %addid = ();
+                if ($userdata{$key} ne '') {
+                    my $idfromenv = $userdata{$key};
+                    if ($key eq 'id') {
+                        $idfromenv=~tr/A-Z/a-z/;
+                        $addid{$idfromenv} = 1;
+                    } else {
+                        $idfromenv =~ s/^\s+//;
+                        $idfromenv =~ s/\s+$//;
+                        map { $addid{$_} = 1; } split(/,/,$idfromenv);
+                    }
+                }
+                if (ref($ids_by_name{$key}{$uname}) eq 'ARRAY') {
+                    if (scalar(@{$ids_by_name{$key}{$uname}}) > 1) {
+                        &log(0,"Multiple $idtext{$key} found in $namespace{$key}.db for $uname:$dom -- ".
+                             join(', ',@{$ids_by_name{$key}{$uname}}));
+                    }
+                    foreach my $id (@{$ids_by_name{$key}{$uname}}) {
+                         if ($addid{$id}) {
+                            delete($addid{$id});
+                         } else {
+                            if ($key eq 'id') {
+                                $idstodelete{$key}{$id} = $uname;
+                            } else {
+                                $idstodelete{$key}{$id} .= $uname.',';
+                            }
                         }
                     }
                 }
-            }
-            if ($addid ne '') {
-                if (exists($idstoadd{$addid})) {
-                    push(@{$duplicates{$addid}},$uname);
-                } else {
-                    $idstoadd{$addid} = $uname;
+                if (keys(%addid)) {
+                    foreach my $id (keys(%addid)) {
+                        if ($key eq 'id') {
+                            if (exists($idstoadd{$key}{$id})) {
+                                push(@{$duplicates{$id}},$uname);
+                            } else {
+                                $idstoadd{$key}{$id} = $uname;
+                            }
+                        } else {
+                            $idstoadd{$key}{$id} .= $uname.',';
+                        }
+                    }
                 }
             }
         }
-        
+
         $userdata{'username'} = $uname;
         $userdata{'domain'} = $dom;
         my %alluserslog = 
@@ -333,63 +384,87 @@
         }
     }
     unless ($simulate || $oneuser) {
-        if (keys(%idstodelete) > 0) {
-            my %resulthash = &Apache::lonnet::iddel($dom,\%idstodelete,$hostid);
-            if ($resulthash{$hostid} eq 'ok') {
-                foreach my $id (sort(keys(%idstodelete))) {
-                    &log(0,"Record deleted from ids.db for $dom -- $id => ".$idstodelete{$id});
+        foreach my $key ('id','clickers') { 
+            if (keys(%{$idstodelete{$key}}) > 0) {
+                my %resulthash;
+                if ($key eq 'id') {
+                    %resulthash = &Apache::lonnet::iddel($dom,$idstodelete{$key},$hostid,$namespace{$key});
+                } else {
+                    foreach my $delid (sort(keys(%{$idstodelete{$key}}))) {
+                        $idstodelete{$key}{$delid} =~ s/,$//;
+                    }
+                    %resulthash = &Apache::lonnet::iddel($dom,$idstodelete{$key},$hostid,$namespace{$key});
                 }
-            } else {
-                &log(0,"Error: '$resulthash{$hostid}' occurred when attempting to delete records from ids.db for $dom");
-            }
-        }
-        if (keys(%idstoadd) > 0) {
-            my $idmessage = '';
-            my %newids;
-            foreach my $addid (sort(keys(%idstoadd))) {
-                if ((exists($names_by_id{$addid})) && ($names_by_id{$addid} ne $idstoadd{$addid})  && !($idstodelete{$addid})) {
-                    &log(0,"Two usernames associated with a single ID $addid in domain: $dom: $names_by_id{$addid} (current) and $idstoadd{$addid}\n");
-                    $idmessage .= "$addid,$names_by_id{$addid},$idstoadd{$addid}\n";
+                if ($resulthash{$hostid} eq 'ok') {
+                    foreach my $id (sort(keys(%{$idstodelete{$key}}))) {
+                        &log(0,"Record deleted from $namespace{$key}.db for $dom -- $id => ".$idstodelete{$key}{$id});
+                    }
                 } else {
-                    $newids{$addid} = $idstoadd{$addid};
+                    &log(0,"Error: '$resulthash{$hostid}' occurred when attempting to delete records from $namespace{$key}.db for $dom");
                 }
             }
-            if (keys(%newids) > 0) {
-                my $putresult = &Apache::lonnet::put_dom('ids',\%idstoadd,$dom,$hostid);
-                if ($putresult eq 'ok') {
-                    foreach my $id (sort(keys(%idstoadd))) {
-                        &log(0,"Record added to ids.db for $dom -- $id => ".$idstoadd{$id});
+            if (keys(%{$idstoadd{$key}}) > 0) {
+                my $idmessage = '';
+                my %newids;
+                if ($key eq 'id') {
+                    foreach my $addid (sort(keys(%{$idstoadd{$key}}))) {
+                        if ((exists($names_by_id{$key}{$addid})) && ($names_by_id{$key}{$addid} ne $idstoadd{$key}{$addid})  && !($idstodelete{$key}{$addid})) {
+                            &log(0,"Two usernames associated with a single ID $addid in domain: $dom: $names_by_id{$key}{$addid} (current) and $idstoadd{$key}{$addid}\n");
+                            $idmessage .= "$addid,$names_by_id{$key}{$addid},$idstoadd{$key}{$addid}\n";
+                        } else {
+                            $newids{$addid} = $idstoadd{$key}{$addid};
+                        }
                     }
                 } else {
-                    &log(0,"Error: '$putresult' occurred when attempting to add records to ids.db for $dom"); 
+                    foreach my $addid (sort(keys(%{$idstoadd{$key}}))) {
+                        $idstoadd{$key}{$addid} =~ s/,$//;
+                        $newids{$addid} = $idstoadd{$key}{$addid};
+                    }
                 }
-            }
-            if ($idmessage) {
-                my $to = &Apache::loncommon::build_recipient_list(undef,'idconflictsmail',$dom);
-                if ($to ne '') {
-                    my $msg = new Mail::Send;
-                    $msg->to($to);
-                    $msg->subject('LON-CAPA studentIDs conflict');
-                    my $lonhost = $Apache::lonnet::perlvar{'lonHostID'};
-                    my $hostname = &Apache::lonnet::hostname($lonhost);
-                    my $replytoaddress = 'do-not-reply@'.$hostname;
-                    $msg->add('Reply-to',$replytoaddress);
-                    $msg->add('From','www@'.$hostname);
-                    $msg->add('Content-type','text/plain; charset=UTF-8');
-                    if (my $fh = $msg->open()) {
-                        print $fh 
-                            'The following IDs are used for more than one user in your domain:'."\n".
-                            'Each row contains: Student/Employee ID, Current username in ids.db file, '.
-                            'Additional username'."\n\n".
-                            $idmessage;
-                        $fh->close;
+                if (keys(%newids) > 0) {
+                    my $putresult;
+                    if ($key eq 'clickers') {
+                        $putresult = &Apache::lonnet::updateclickers($dom,'add',\%newids,$hostid); 
+                    } else {
+                        $putresult = &Apache::lonnet::put_dom($namespace{$key},\%newids,$dom,$hostid);
+                    } 
+                    if ($putresult eq 'ok') {
+                        foreach my $id (sort(keys(%newids))) {
+                            &log(0,"Record added to $namespace{$key}.db for $dom -- $id => ".$newids{$id});
+                        }
+                    } else {
+                        &log(0,"Error: '$putresult' occurred when attempting to add records to $namespace{$key}.db for $dom"); 
+                    }
+                }
+                if ($idmessage) {
+                    my $to = &Apache::loncommon::build_recipient_list(undef,'idconflictsmail',$dom);
+                    if ($to ne '') {
+                        my $msg = new Mail::Send;
+                        $msg->to($to);
+                        $msg->subject('LON-CAPA studentIDs conflict');
+                        my $lonhost = $Apache::lonnet::perlvar{'lonHostID'};
+                        my $hostname = &Apache::lonnet::hostname($lonhost);
+                        my $replytoaddress = 'do-not-reply@'.$hostname;
+                        $msg->add('Reply-to',$replytoaddress);
+                        $msg->add('From','www@'.$hostname);
+                        $msg->add('Content-type','text/plain; charset=UTF-8');
+                        if (my $fh = $msg->open()) {
+                            print $fh 
+                                'The following IDs are used for more than one user in your domain:'."\n".
+                                'Each row contains: Student/Employee ID, Current username in ids.db file, '.
+                                'Additional username'."\n\n".
+                                $idmessage;
+                            $fh->close;
+                        }
                     }
                 }
             }
         }
         if (keys(%duplicates) > 0) {
             foreach my $id (sort(keys(%duplicates))) {
-                &log(0,"Duplicate IDs found for entries to add to ids.db in $dom -- $id => $idstodelete{$id}");
+                if (ref($duplicates{$id}) eq 'ARRAY') {
+                    &log(0,"Duplicate IDs found for entries to add to ids.db in $dom -- $id => ".join(',',@{$duplicates{$id}}));
+                }
             }
         }
     }
Index: loncom/lond
diff -u loncom/lond:1.516 loncom/lond:1.517
--- loncom/lond:1.516	Sun Jun 14 00:43:51 2015
+++ loncom/lond	Sun Jan 31 21:25:53 2016
@@ -2,7 +2,7 @@
 # The LearningOnline Network
 # lond "LON Daemon" Server (port "LOND" 5663)
 #
-# $Id: lond,v 1.516 2015/06/14 00:43:51 raeburn Exp $
+# $Id: lond,v 1.517 2016/01/31 21:25:53 raeburn Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -61,7 +61,7 @@
 my $status='';
 my $lastlog='';
 
-my $VERSION='$Revision: 1.516 $'; #' stupid emacs
+my $VERSION='$Revision: 1.517 $'; #' stupid emacs
 my $remoteVERSION;
 my $currenthostid="default";
 my $currentdomainid;
@@ -4377,6 +4377,122 @@
 }
 &register_handler("putdom", \&put_domain_handler, 0, 1, 0);
 
+# Updates one or more entries in clickers.db file at the domain level
+#
+# Parameters:
+#    $cmd      - The command that got us here.
+#    $tail     - Tail of the command (remaining parameters).
+#                In this case a colon separated list containing:
+#                (a) the domain for which we are updating the entries,
+#                (b) the action required -- add or del -- and
+#                (c) a &-separated list of entries to add or delete.
+#    $client   - File descriptor connected to client.
+# Returns
+#     1        - Continue processing.
+#     0        - Requested to exit, caller should shut down.
+#  Side effects:
+#     reply is written to $client.
+#
+
+
+sub update_clickers {
+    my ($cmd, $tail, $client)  = @_;
+
+    my $userinput = "$cmd:$tail";
+    my ($udom,$action,$what) =split(/:/,$tail,3);
+    chomp($what);
+
+    my $hashref = &tie_domain_hash($udom, "clickers", &GDBM_WRCREAT(),
+                                 "U","$action:$what");
+
+    if (!$hashref) {
+        &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
+                  "while attempting updateclickers\n", $userinput);
+        return 1;
+    }
+
+    my @pairs=split(/\&/,$what);
+    foreach my $pair (@pairs) {
+        my ($key,$value)=split(/=/,$pair);
+        if ($action eq 'add') {
+            if (exists($hashref->{$key})) {
+                my @newvals = split(/,/,&unescape($value));
+                my @currvals = split(/,/,&unescape($hashref->{$key}));
+                my @merged = sort(keys(%{{map { $_ => 1 } (@newvals, at currvals)}}));
+                $hashref->{$key}=&escape(join(',', at merged));
+            } else {
+                $hashref->{$key}=$value;
+            }
+        } elsif ($action eq 'del') {
+            if (exists($hashref->{$key})) {
+                my %current;
+                map { $current{$_} = 1; } split(/,/,&unescape($hashref->{$key}));
+                map { delete($current{$_}); } split(/,/,&unescape($value));
+                if (keys(%current)) {
+                    $hashref->{$key}=&escape(join(',',sort(keys(%current))));
+                } else {
+                    delete($hashref->{$key});
+                }
+            }
+        }
+    }
+    if (&untie_user_hash($hashref)) {
+        &Reply( $client, "ok\n", $userinput);
+    } else {
+        &Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
+                 "while attempting put\n",
+                 $userinput);
+    }
+    return 1;
+}
+&register_handler("updateclickers", \&update_clickers, 0, 1, 0);
+
+
+# Deletes one or more entries in a namespace db file at the domain level
+#
+# Parameters:
+#    $cmd      - The command that got us here.
+#    $tail     - Tail of the command (remaining parameters).
+#                In this case a colon separated list containing:
+#                (a) the domain for which we are deleting the entries,
+#                (b) &-separated list of keys to delete.  
+#    $client   - File descriptor connected to client.
+# Returns
+#     1        - Continue processing.
+#     0        - Requested to exit, caller should shut down.
+#  Side effects:
+#     reply is written to $client.
+#
+
+sub del_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(),
+                                   "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;
+}
+&register_handler("deldom", \&del_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.
@@ -7699,7 +7815,7 @@
 
 Make a user.
 
-=item passwd
+=item changeuserauth
 
 Allow for authentication mechanism and password to be changed.
 
@@ -7788,6 +7904,10 @@
 Returns usernames corresponding to IDs.  (These "IDs" are unique identifiers
 for each student, defined perhaps by the institutional Registrar.)
 
+=item iddel
+
+Deletes one or more ids in a domain's id database.
+
 =item tmpput
 
 Accept and store information in temporary space.
Index: loncom/lonnet/perl/lonnet.pm
diff -u loncom/lonnet/perl/lonnet.pm:1.1299 loncom/lonnet/perl/lonnet.pm:1.1300
--- loncom/lonnet/perl/lonnet.pm:1.1299	Sun Jan 31 16:40:22 2016
+++ loncom/lonnet/perl/lonnet.pm	Sun Jan 31 21:25:57 2016
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.1299 2016/01/31 16:40:22 raeburn Exp $
+# $Id: lonnet.pm,v 1.1300 2016/01/31 21:25:57 raeburn Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -1551,17 +1551,33 @@
     return 'no_host';
 }
 
-# ------------------------------------- Find the usernames behind a list of IDs
+# ----- Find the usernames behind a list of student/employee IDs or clicker IDs
 
 sub idget {
-    my ($udom, at ids)=@_;
+    my ($udom,$idsref,$namespace)=@_;
     my %returnhash=();
+    my @ids=(); 
+    if (ref($idsref) eq 'ARRAY') {
+        @ids = @{$idsref};
+    } else {
+        return %returnhash; 
+    }
+    if ($namespace eq '') {
+        $namespace = 'ids';
+    }
     
     my %servers = &get_servers($udom,'library');
     foreach my $tryserver (keys(%servers)) {
 	my $idlist=join('&', map { &escape($_); } @ids);
-	$idlist=~tr/A-Z/a-z/; 
-	my $reply=&reply("idget:$udom:".$idlist,$tryserver);
+	if ($namespace eq 'ids') {
+	    $idlist=~tr/A-Z/a-z/;
+	}
+	my $reply;
+	if ($namespace eq 'ids') {
+	    $reply=&reply("idget:$udom:".$idlist,$tryserver);
+	} else {
+	    $reply=&reply("getdom:$udom:$namespace:$idlist",$tryserver);
+	}
 	my @answer=();
 	if (($reply ne 'con_lost') && ($reply!~/^error\:/)) {
 	    @answer=split(/\&/,$reply);
@@ -1570,9 +1586,9 @@
 	for ($i=0;$i<=$#ids;$i++) {
 	    if ($answer[$i]) {
 		$returnhash{$ids[$i]}=&unescape($answer[$i]);
-	    } 
+	    }
 	}
-    } 
+    }
     return %returnhash;
 }
 
@@ -1587,60 +1603,141 @@
     return %returnhash;
 }
 
-# ------------------------------- Store away a list of names and associated IDs
+# Store away a list of names and associated student/employee IDs or clicker IDs
 
 sub idput {
-    my ($udom,%ids)=@_;
+    my ($udom,$idsref,$uhom,$namespace)=@_;
     my %servers=();
+    my %ids=();
+    my %byid = ();
+    if (ref($idsref) eq 'HASH') {
+        %ids=%{$idsref};
+    }
+    if ($namespace eq '') {
+        $namespace = 'ids'; 
+    }
     foreach my $uname (keys(%ids)) {
 	&cput('environment',{'id'=>$ids{$uname}},$udom,$uname);
-        my $uhom=&homeserver($uname,$udom);
+        if ($uhom eq '') {
+            $uhom=&homeserver($uname,$udom);
+        }
         if ($uhom ne 'no_host') {
-            my $id=&escape($ids{$uname});
-            $id=~tr/A-Z/a-z/;
             my $esc_unam=&escape($uname);
-	    if ($servers{$uhom}) {
-		$servers{$uhom}.='&'.$id.'='.$esc_unam;
+            if ($namespace eq 'ids') {
+                my $id=&escape($ids{$uname});
+                $id=~tr/A-Z/a-z/;
+                my $esc_unam=&escape($uname);
+                $servers{$uhom}.=$id.'='.$esc_unam.'&';
             } else {
-                $servers{$uhom}=$id.'='.$esc_unam;
+                my @currids = split(/,/,$ids{$uname});
+                foreach my $id (@currids) {
+                    $byid{$uhom}{$id} .= $uname.',';
+                }
+            }
+        }
+    }
+    if ($namespace eq 'clickers') {
+        foreach my $server (keys(%byid)) {
+            if (ref($byid{$server}) eq 'HASH') {
+                foreach my $id (keys(%{$byid{$server}})) {
+                    $byid{$server} =~ s/,$//;
+                    $servers{$uhom}.=&escape($id).'='.&escape($byid{$server}).'&'; 
+                }
             }
         }
     }
     foreach my $server (keys(%servers)) {
-        &critical('idput:'.$udom.':'.$servers{$server},$server);
+        $servers{$server} =~ s/\&$//;
+        if ($namespace eq 'ids') {     
+            &critical('idput:'.$udom.':'.$servers{$server},$server);
+        } else {
+            &critical('updateclickers:'.$udom.':add:'.$servers{$server},$server);
+        }
     }
 }
 
-# ---------------------------------------- Delete unwanted IDs from ids.db file 
+# ------------- Delete unwanted student/employee IDs or clicker IDs from domain
 
 sub iddel {
-    my ($udom,$idshashref,$uhome)=@_;
+    my ($udom,$idshashref,$uhome,$namespace)=@_;
     my %result=();
-    unless (ref($idshashref) eq 'HASH') {
+    my %ids=();
+    my %byid = ();
+    if (ref($idshashref) eq 'HASH') {
+        %ids=%{$idshashref};
+    } else {
         return %result;
     }
+    if ($namespace eq '') {
+        $namespace = 'ids';
+    }
     my %servers=();
-    while (my ($id,$uname) = each(%{$idshashref})) {
-        my $uhom;
-        if ($uhome) {
-            $uhom = $uhome;
-        } else {
-            $uhom=&homeserver($uname,$udom);
-        }
-        if ($uhom ne 'no_host') {
-            if ($servers{$uhom}) {
+    while (my ($id,$unamestr) = each(%ids)) {
+        if ($namespace eq 'ids') {
+            my $uhom = $uhome;
+            if ($uhom eq '') { 
+                $uhom=&homeserver($unamestr,$udom);
+            }
+            if ($uhom ne 'no_host') {
                 $servers{$uhom}.='&'.&escape($id);
-            } else {
-                $servers{$uhom}=&escape($id);
+            }
+         } else {
+            my @curritems = split(/,/,$ids{$id});
+            foreach my $uname (@curritems) {
+                my $uhom = $uhome;
+                if ($uhom eq '') {
+                    $uhom=&homeserver($uname,$udom);
+                }
+                if ($uhom ne 'no_host') { 
+                    $byid{$uhom}{$id} .= $uname.',';
+                }
+            }
+        }
+    }
+    if ($namespace eq 'clickers') {
+        foreach my $server (keys(%byid)) {
+            if (ref($byid{$server}) eq 'HASH') {
+                foreach my $id (keys(%{$byid{$server}})) {
+                    $byid{$server}{$id} =~ s/,$//;
+                    $servers{$server}.=&escape($id).'='.&escape($byid{$server}{$id}).'&';
+                }
             }
         }
     }
     foreach my $server (keys(%servers)) {
-        $result{$server} = &critical('iddel:'.$udom.':'.$servers{$server},$uhome);
+        $servers{$server} =~ s/\&$//;
+        if ($namespace eq 'ids') {
+            $result{$server} = &critical('iddel:'.$udom.':'.$servers{$server},$uhome);
+        } elsif ($namespace eq 'clickers') {
+            $result{$server} = &critical('updateclickers:'.$udom.':del:'.$servers{$server},$server);
+        }
     }
     return %result;
 }
 
+# ----- Update clicker ID-to-username look-ups in clickers.db on library server 
+
+sub updateclickers {
+    my ($udom,$action,$idshashref,$uhome,$critical) = @_;
+    my %clickers;
+    if (ref($idshashref) eq 'HASH') {
+        %clickers=%{$idshashref};
+    } else {
+        return;
+    }
+    my $items='';
+    foreach my $item (keys(%clickers)) {
+        $items.=&escape($item).'='.&escape($clickers{$item}).'&';
+    }
+    $items=~s/\&$//;
+    my $request = "updateclickers:$udom:$action:$items";
+    if ($critical) {
+        return &critical($request,$uhome);
+    } else {
+        return &reply($request,$uhome);
+    }
+}
+
 # ------------------------------dump from db file owned by domainconfig user
 sub dump_dom {
     my ($namespace, $udom, $regexp) = @_;
@@ -8813,7 +8910,7 @@
                   'current user id "'.$uidhash{$uname}.'".';
           }
        } else {
-	  &idput($udom,($uname => $uid));
+	  &idput($udom,{$uname => $uid},$uhome,'ids');
        }
     }
 # -------------------------------------------------------------- Add names, etc
@@ -13190,10 +13287,12 @@
 
 =item *
 X<idget()>
-B<idget($udom, at ids)>: find the usernames behind a list of IDs
-(IDs are a unique resource in a domain, there must be only 1 ID per
-username, and only 1 username per ID in a specific domain) (returns
-hash: id=>name,id=>name)
+B<idget($udom,$idsref,$namespace)>: find the usernames behind either 
+a list of student/employee IDs or clicker IDs
+(student/employee IDs are a unique resource in a domain, there must be 
+only 1 ID per username, and only 1 username per ID in a specific domain).
+clickerIDs are not necessarily unique, as students might share clickers.
+(returns hash: id=>name,id=>name)
 
 =item *
 X<idrget()>
@@ -13202,7 +13301,27 @@
 
 =item *
 X<idput()>
-B<idput($udom,%ids)>: store away a list of names and associated IDs
+B<idput($udom,$idsref,$uhome,$namespace)>: store away a list of 
+names and associated student/employee IDs or clicker IDs.
+
+=item *
+X<iddel()>
+B<iddel($udom,$idshashref,$uhome,$namespace)>: delete unwanted 
+student/employee ID or clicker ID username look-ups from domain.
+The homeserver ($uhome) and namespace ($namespace) are optional.
+If no $uhome is provided, it will be determined usig &homeserver()
+for each user.  If no $namespace is provided, the default is ids.
+
+=item *
+X<updateclickers()>
+B<updateclickers($udom,$action,$idshashref,$uhome,$critical)>: update 
+clicker ID-to-username look-ups in clickers.db on library server.
+Permitted actions are add or del (i.e., add or delete). The 
+clickers.db contains clickerID as keys (escaped), and each corresponding
+value is an escaped comma-separated list of usernames (for whom the
+library server is the homeserver), who registered that particular ID.
+If $critical is true, the update will be sent via &critical, otherwise
+&reply() will be used.
 
 =item *
 X<rolesinit()>
Index: loncom/debugging_tools/rebuild_db_from_hist.pl
diff -u loncom/debugging_tools/rebuild_db_from_hist.pl:1.6 loncom/debugging_tools/rebuild_db_from_hist.pl:1.7
--- loncom/debugging_tools/rebuild_db_from_hist.pl:1.6	Thu Aug  3 17:53:47 2006
+++ loncom/debugging_tools/rebuild_db_from_hist.pl	Sun Jan 31 21:26:01 2016
@@ -4,7 +4,7 @@
 #
 # rebuild_db_from_hist.pl Rebuild a *.db file from a *.hist file
 #
-# $Id: rebuild_db_from_hist.pl,v 1.6 2006/08/03 17:53:47 albertel Exp $
+# $Id: rebuild_db_from_hist.pl,v 1.7 2016/01/31 21:26:01 raeburn Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -125,13 +125,14 @@
         #  D:delete
         #  N:new put (only adds tha values if they are all new values)
 	#  M:modify the values for a previous S
+        #  U:update the values (action could be add or del).
         my ($action,$time,$concatenated_data) = split(':',$command,3);
         if ($fname eq 'roles.hist' && $concatenated_data =~ /^.*:.*:/) {
             (undef,undef,$concatenated_data) = split(':',$concatenated_data,3);
         }
         next if (! defined($action));
         if ($action eq 'P' && $p_is_s) { $action = 'S'; }
-        my ($rid, at allkeys,$version);
+        my ($rid, at allkeys,$version,$updatetype);
         if ($action eq 'S') {
             ($rid,$concatenated_data) = split(':',$concatenated_data,2);
             $version = ++$db_to_store{"version:$rid"};
@@ -141,6 +142,10 @@
             ($rid,$version,$concatenated_data) = 
 		split(':',$concatenated_data,3);
 	}
+        if ($action eq 'U') {
+            ($updatetype,$concatenated_data) =
+                split(':',$concatenated_data,2); 
+        }
         next if (! defined($concatenated_data));
 	my $add_new_data = 1;
         my @data = split('&',$concatenated_data);
@@ -163,6 +168,28 @@
 		}
             } elsif ($action eq 'D') {
                 delete($db_to_store{$key});
+            } elsif ($action eq 'U') {
+                if ($updatetype eq 'del') {
+                    if (exists($db_to_store{$key})) {
+                        my %current;
+                        map { $current{$_} = 1; } split(/,/,&unescape($db_to_store{$key}));
+                        map { delete($current{$_}); } split(/,/,&unescape($value));
+                        if (keys(%current)) {
+                            $db_to_store{$key}=&escape(join(',',sort(keys(%current))));
+                        } else {
+                            delete($db_to_store{$key});
+                        }
+                    }
+                } elsif ($updatetype eq 'add') {
+                    if (exists($db_to_store{$key})) {
+                        my @newvals = split(/,/,&unescape($value));
+                        my @currvals = split(/,/,&unescape($db_to_store{$key}));
+                        my @merged = sort(keys(%{{map { $_ => 1 } (@newvals, at currvals)}}));
+                        $db_to_store{$key}=&escape(join(',', at merged));
+                    } else {
+                        $db_to_store{$key}=$value;
+                    }
+                }
             } else {
                 $error = "Unable to understand action '".$action."'";
             }


More information about the LON-CAPA-cvs mailing list