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

[raeburn]

raeburn		Fri Oct 24 00:37:15 2014 EDT

  Modified files:              (Branch: version_2_11_X)
    /loncom/lonnet/perl	lonnet.pm 
  Log:
  - For 2.11
    - Backport 1.1268
  
  
Index: loncom/lonnet/perl/lonnet.pm
diff -u loncom/lonnet/perl/lonnet.pm:1.1172.2.55 loncom/lonnet/perl/lonnet.pm:1.1172.2.56
--- loncom/lonnet/perl/lonnet.pm:1.1172.2.55	Mon Oct 13 15:47:14 2014
+++ loncom/lonnet/perl/lonnet.pm	Fri Oct 24 00:37:15 2014
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.1172.2.55 2014/10/13 15:47:14 raeburn Exp $
+# $Id: lonnet.pm,v 1.1172.2.56 2014/10/24 00:37:15 raeburn Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -6063,10 +6063,15 @@
         my %inuse = &Apache::lonnet::dump('nohist_'.$namespace,$cdom,$cnum,$prefix);
         my $id = time;
         $newid = $id;
+        if ($idtype eq 'addcode') {
+            $newid .= &sixnum_code();
+        }
         my $idtries = 0;
         while (exists($inuse{$prefix."\0".$newid}) && $idtries < $maxtries) {
             if ($idtype eq 'concat') {
                 $newid = $id.$idtries;
+            } elsif ($idtype eq 'addcode') {
+                $newid = $newid.&sixnum_code();
             } else {
                 $newid ++;
             }
@@ -6083,6 +6088,7 @@
                 $error = 'error saving new item: '.$putresult;
             }
         } else {
+             undef($newid);
              $error = ('error: no unique suffix available for the new item ');
         }
 #  remove lock
@@ -6095,6 +6101,14 @@
     return ($newid,$dellock,$error);
 }
 
+sub sixnum_code {
+    my $code;
+    for (0..6) {
+        $code .= int( rand(9) );
+    }
+    return $code;
+}
+
 # -------------------------------------------------- portfolio access checking
 
 sub portfolio_access {