[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 @@
}
®ister_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;
+}
+®ister_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;
+}
+®ister_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