--- loncom/interface/lonclonecourse.pm	2020/06/01 20:35:02	1.14
+++ loncom/interface/lonclonecourse.pm	2020/07/01 20:08:54	1.15
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # routines for clone a course
 #
-# $Id: lonclonecourse.pm,v 1.14 2020/06/01 20:35:02 raeburn Exp $
+# $Id: lonclonecourse.pm,v 1.15 2020/07/01 20:08:54 raeburn Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -30,6 +30,7 @@
 package Apache::lonclonecourse;
 use LONCAPA;
 use Apache::lonnet;
+use Apache::lonlocal;
 use DateTime();
 use DateTime::TimeZone;
 
@@ -130,10 +131,14 @@ sub copyfile {
 # =============================================================== Copy a dbfile
 
 sub copydb {
-    my ($origcrsid,$newcrsid,$which,$newinstcode)=@_;
+    my ($origcrsid,$newcrsid,$which,$newinstcode,$newowner,$tinyurls)=@_;
     $which=~s/\.db$//;
     my %origcrsdata=&Apache::lonnet::coursedescription($origcrsid);
     my %newcrsdata= &Apache::lonnet::coursedescription($newcrsid);
+    if (($which eq 'tiny') && ($tinyurls eq 'delete')) {
+        return ();
+    }
+    my @info;
     my %data=&Apache::lonnet::dump
 	($which,$origcrsdata{'domain'},$origcrsdata{'num'});
     foreach my $key (keys(%data)) {
@@ -146,9 +151,89 @@ sub copydb {
         if ($origcrsdata{'internal.coursecode'} ne $newinstcode) {
             $data{'crslabel'} =~ s/\Q$origcrsdata{'internal.coursecode'}\E/$newinstcode/;
         }
+    } elsif ($which eq 'tiny') {
+        my $oldprefix = 'uploaded/'.$origcrsdata{'domain'}.'/'.$origcrsdata{'num'}.'/';
+        my $newprefix = 'uploaded/'.$newcrsdata{'domain'}.'/'. $newcrsdata{'num'}.'/';
+        my (%domtiny,%tocreate,@todelete,$numnew,$errors);
+        if (($tinyurls eq 'transfer') && (keys(%data))) {
+            unless (($origcrsdata{'internal.courseowner'} eq $newowner) &&
+                    ($origcrsdata{'domain'} eq $newcrsdata{'domain'})) {
+                $tinyurls = 'create';
+                push(@info,{
+                             mt => "Action for URL shortcut(s) changed from 'transfer' to 'create' ".
+                                   "because requirements of same owner and some course domain ".
+                                   "for new course and original course not met.",
+                             args => [],
+                           });
+            }
+        }
+        foreach my $key (keys(%data)) {
+            my $code = $data{$key};
+            my $newkey = $key;
+            $newkey =~ s{\Q$oldprefix\E}{$newprefix}g;
+            if ($tinyurls eq 'transfer') {
+                $data{$newkey} = $code;
+                $domtiny{$code} = $newcrsdata{'num'}.'&'.$newkey;
+                push(@todelete,$key);
+            } else {
+                $tocreate{$newcrsdata{'num'}.'&'.$newkey} = 1;
+            }
+            delete($data{$key});
+        }
+        if (keys(%tocreate)) {
+            ($numnew,$errors) = &Apache::loncommon::make_short_symbs($newcrsdata{'domain'},
+                                                                     $newcrsdata{'num'},
+                                                                     \%tocreate,$newowner);
+            if ((ref($errors) eq 'ARRAY') && (@{$errors} > 0)) {
+                push(@info,{
+                            mt => 'Error(s) when creating URL shortcut(s) in new course for equivalent '.
+                                  'resource(s)/folder(s) in original course: [_1]',
+                            args => [join(', ',@{$errors})],
+                           });
+            }
+            if ($numnew) {
+                push(@info,{
+                            mt => 'New URL shortcut(s) in new course for [quant,_1,item] to replicate '.
+                                  'shortcut(s) for equivalent(s) in original course.',
+                            args => [$numnew],
+                           });
+            }
+            return @info;
+        } elsif (keys(%domtiny)) {
+            my $configuname = &Apache::lonnet::get_domainconfiguser($newcrsdata{'domain'});
+            my $putdomres = &Apache::lonnet::put('tiny',\%domtiny,$newcrsdata{'domain'},$configuname);
+            if ($putdomres eq 'ok') {
+                my $delres = &Apache::lonnet::del('tiny',\@todelete,
+                                                 $origcrsdata{'domain'},
+                                                 $origcrsdata{'num'});
+
+                if ($delres eq 'ok') {
+                    push(@info,{
+                                 mt => 'URL shortcut(s) for [quant,_1,item] transferred, and '.
+                                       'now point to resource(s)/folder(s) in new course instead of '.
+                                       'equivalent(s) in original course.',
+                                 args => [scalar(keys(%domtiny))],
+                               });
+                } else {
+                    push(@info,{
+                                 mt => 'Failed to delete URL shortcut(s) in original course '.
+                                       'when attempting to transfer to new course.',
+                                 args => [],
+                               });
+                }
+            } else {
+                push(@info,{
+                              mt => 'Failed to store update of target course for URL shortcut(s) in '.
+                                    'domain records.',
+                              args => [],
+                           });
+                return @info;
+            }
+        }
     }
-    return &Apache::lonnet::put
-	($which,\%data,$newcrsdata{'domain'},$newcrsdata{'num'});
+    my $putres = &Apache::lonnet::put
+                     ($which,\%data,$newcrsdata{'domain'},$newcrsdata{'num'});
+    return @info;
 }
 
 # ========================================================== Copy resourcesdata
@@ -259,32 +344,41 @@ sub copyuserfiles {
 	    &copyfile($origcrsid,$newcrsid,$_);
 	}
     }
+    return;
 }
 # ========================================================== Copy all userfiles
 
 sub copydbfiles {
-    my ($origcrsid,$newcrsid,$newinstcode)=@_;
+    my ($origcrsid,$newcrsid,$newinstcode,$newowner,$tinyurls)=@_;
+    my @copyinfo;
 
     my ($origcrs_discussion) = ($origcrsid=~m|^/(.*)|);
     $origcrs_discussion=~s|/|_|g;
     foreach (&crsdirlist($origcrsid)) {
-	if ($_=~/\.db$/) {
-        unless ($_=~/^(nohist\_|disclikes|discussiontimes|classlist|versionupdate
-                |resourcedata|\Q$origcrs_discussion\E|slots|slot_reservations
-                |gradingqueue|reviewqueue|CODEs|groupmembership|comm_block)/) {
-            &copydb($origcrsid,$newcrsid,$_,$newinstcode);
+        if ($_=~/\.db$/) {
+            unless ($_=~/^(nohist\_|disclikes|discussiontimes|classlist|versionupdate
+                   |resourcedata|\Q$origcrs_discussion\E|slots|slot_reservations
+                   |gradingqueue|reviewqueue|CODEs|groupmembership|comm_block)/) {
+                my @info = &copydb($origcrsid,$newcrsid,$_,$newinstcode,$newowner,
+                                   $tinyurls);
+                if (@info) {
+                    push(@copyinfo,@info);
+                }
+            }
         }
-	}
     }
+    return @copyinfo;
 }
 
 # ======================================================= Copy all course files
 
 sub copycoursefiles {
-    my ($origcrsid,$newcrsid,$date_mode,$date_shift,$newinstcode)=@_;
+    my ($origcrsid,$newcrsid,$date_mode,$date_shift,$newinstcode,$newowner,
+        $tinyurls)=@_;
     &copyuserfiles($origcrsid,$newcrsid);
-    &copydbfiles($origcrsid,$newcrsid,$newinstcode);
+    my @info = &copydbfiles($origcrsid,$newcrsid,$newinstcode,$newowner,$tinyurls);
     &copyresourcedb($origcrsid,$newcrsid,$date_mode,$date_shift);
+    return @info;
 }
 
 1;