--- loncom/interface/lonclonecourse.pm	2010/02/26 22:45:03	1.7.12.1
+++ loncom/interface/lonclonecourse.pm	2022/03/25 06:42:17	1.18
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # routines for clone a course
 #
-# $Id: lonclonecourse.pm,v 1.7.12.1 2010/02/26 22:45:03 raeburn Exp $
+# $Id: lonclonecourse.pm,v 1.18 2022/03/25 06:42:17 raeburn Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -30,7 +30,9 @@
 package Apache::lonclonecourse;
 use LONCAPA;
 use Apache::lonnet;
-use Apache::loncoursedata;
+use Apache::lonlocal;
+use DateTime();
+use DateTime::TimeZone;
 
 # ================================================ Get course directory listing
 
@@ -49,20 +51,23 @@ sub innercrsdirlist {
     unless ($path)  { $path=''; } else { $path.='/'; }
     my %crsdata=&Apache::lonnet::coursedescription($courseid);
     my $getpropath = 1;
-    my @listing=&Apache::lonnet::dirlist
-	($which,$crsdata{'domain'},$crsdata{'num'},$getpropath);
-    foreach (@listing) {
-	unless ($_=~/^\./) {
-	    my @unpackline = split (/\&/,$_);
-	    if ($unpackline[3]&$dirptr) {
+    my ($dirlistref,$listerror) = 
+        &Apache::lonnet::dirlist($which,$crsdata{'domain'},
+                                 $crsdata{'num'},$getpropath);
+    if (ref($dirlistref) eq 'ARRAY') {
+        foreach (@{$dirlistref}) {
+	    unless ($_=~/^\./) {
+	        my @unpackline = split (/\&/,$_);
+	        if ($unpackline[3]&$dirptr) {
 # is a directory, recurse
-		&innercrsdirlist($courseid,$which.$unpackline[0],
-				            $path.$unpackline[0]);
-	    } else { 
+		    &innercrsdirlist($courseid,$which.$unpackline[0],
+				     $path.$unpackline[0]);
+	        } else { 
 # is a file, put into output
-		push (@output,$path.$unpackline[0]);
+		    push (@output,$path.$unpackline[0]);
+	        }
 	    }
-	}
+        }
     }
     return @output;
 }
@@ -103,7 +108,7 @@ sub rewritefile {
 
 sub copyfile {
     my ($origcrsid,$newcrsid,$which)=@_;
-    unless ($which=~/\.sequence$/) {
+    unless ($which=~/\.(page|sequence)$/) {
 	return &writefile($newcrsid,$which,
 		      &readfile($origcrsid,$which));
     } else {
@@ -126,17 +131,117 @@ sub copyfile {
 # =============================================================== Copy a dbfile
 
 sub copydb {
-    my ($origcrsid,$newcrsid,$which)=@_;
+    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)) {
 	if ($key=~/^internal./) { delete($data{$key}); }
     }
-    return &Apache::lonnet::put
-	($which,\%data,$newcrsdata{'domain'},$newcrsdata{'num'});
+    if ($which =~ /^exttool_\d+$/) {
+        if ($origcrsdata{'description'} ne $newcrsdata{'description'}) {
+            $data{'crstitle'} =~s/\Q$origcrsdata{'description'}\E/$newcrsdata{'description'}/;
+        }
+        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;
+            }
+        }
+    } elsif ($which eq 'lti') {
+        foreach my $key (keys(%data)) {
+            if (ref($data{$key}) eq 'HASH') {
+                if (exists($data{$key}{'usable'})) {
+                    delete($data{$key}{'usable'});
+                }
+            }
+        }
+    }
+    my $putres = &Apache::lonnet::put
+                     ($which,\%data,$newcrsdata{'domain'},$newcrsdata{'num'});
+    return @info;
 }
 
 # ========================================================== Copy resourcesdata
@@ -146,6 +251,22 @@ sub copyresourcedb {
     my $delta=$date_shift*60*60*24;
     my %origcrsdata=&Apache::lonnet::coursedescription($origcrsid);
     my %newcrsdata= &Apache::lonnet::coursedescription($newcrsid);
+    my $origtz;
+    if (($date_mode) && ($date_mode ne 'preserve') && ($date_shift) && 
+        (int($date_shift) == $date_shift)) {
+        $origtz = $origcrsdata{'timezone'};
+        if ($origtz eq '') {
+            my %domdefaults = &Apache::lonnet::get_domain_defaults($origcrsdata{'domain'});
+            if ($domdefaults{'timezone_def'} ne '') {
+                $origtz = $domdefaults{'timezone_def'};
+            }
+        }
+        if ($origtz eq '') {
+            $origtz = 'local';
+        } elsif (!DateTime::TimeZone->is_valid_name($origtz)) {
+            $origtz = 'local';
+        }
+    }
     my %data=&Apache::lonnet::dump
 	('resourcedata',$origcrsdata{'domain'},$origcrsdata{'num'});
     $origcrsid=~s/^\///;
@@ -164,7 +285,7 @@ sub copyresourcedb {
 	$startdate = $start{'default_enrollment_start_date'};
     }
 # ugly retro fix for broken version of types
-    foreach my $key (keys %data) {
+    foreach my $key (keys(%data)) {
 	if ($key=~/\wtype$/) {
 	    my $newkey=$key;
 	    $newkey=~s/type$/\.type/;
@@ -175,7 +296,7 @@ sub copyresourcedb {
 # adjust symbs
     my $pattern='uploaded/'.$origcrsdata{'domain'}.'/'.$origcrsdata{'num'}.'/';
     my $new=    'uploaded/'. $newcrsdata{'domain'}.'/'. $newcrsdata{'num'}.'/';
-    foreach my $key (keys %data) {
+    foreach my $key (keys(%data)) {
 	if ($key=~/\Q$pattern\E/) {
 	    my $newkey=$key;
 	    $newkey=~s/\Q$pattern\E/$new/;
@@ -184,7 +305,7 @@ sub copyresourcedb {
 	}
     }
 #  transfer hash
-    foreach my $key (keys %data) {
+    foreach my $key (keys(%data)) {
 	my $thiskey=$key;
 	$thiskey=~s/^$origcrsid/$newcrsid/;
 	$newdata{$thiskey}=$data{$key};
@@ -193,14 +314,30 @@ sub copyresourcedb {
 # date_mode other: do not transfer dates
         if (($date_mode) && ($date_mode ne 'preserve')) {
 	    if ($data{$key.'.type'}=~/^date_(start|end)$/) {
-	       if ($date_mode eq 'shift') {
-		  $newdata{$thiskey}=$newdata{$thiskey}+$delta;
-	       } else {
-		  delete($newdata{$thiskey});
-		  delete($newdata{$thiskey.'.type'});
-	       }
+	        if ($date_mode eq 'shift') {
+                    if (($date_shift) && ($date_shift == int($date_shift))) { 
+                        my $dt = DateTime->from_epoch(epoch => $newdata{$thiskey})
+                                                      ->set_time_zone($origtz);
+                        if (($origtz eq 'local') && (!$ENV{TZ})) {
+                            $ENV{TZ} = $dt->time_zone()->name();
+                        }
+                        eval {
+                            $dt->add(days => int($date_shift));
+                        };
+                        if ($@) {
+                            $newdata{$thiskey} = $newdata{$thiskey}+$delta+(60*60);
+                        } else {
+                            $newdata{$thiskey} = $dt->epoch();
+                        }
+                    } else {
+                        $newdata{$thiskey} = $newdata{$thiskey}+$delta;
+                    }
+                } else {
+                    delete($newdata{$thiskey});
+                    delete($newdata{$thiskey.'.type'});
+                }
             }
-	}
+        }
     }
     return &Apache::lonnet::put
 	('resourcedata',\%newdata,$newcrsdata{'domain'},$newcrsdata{'num'});
@@ -215,94 +352,41 @@ sub copyuserfiles {
 	    &copyfile($origcrsid,$newcrsid,$_);
 	}
     }
+    return;
 }
 # ========================================================== Copy all userfiles
 
 sub copydbfiles {
-    my ($origcrsid,$newcrsid)=@_;
+    my ($origcrsid,$newcrsid,$newinstcode,$newowner,$tinyurls)=@_;
+    my @copyinfo;
 
     my ($origcrs_discussion) = ($origcrsid=~m|^/(.*)|);
     $origcrs_discussion=~s|/|_|g;
     foreach (&crsdirlist($origcrsid)) {
-	if ($_=~/\.db$/) {
-	    unless 
-             ($_=~/^(nohist\_|discussiontimes|classlist|versionupdate|resourcedata|\Q$origcrs_discussion\E|slots|slot_reservations|gradingqueue|reviewqueue|CODEs|groupmembership)/) {
-		 &copydb($origcrsid,$newcrsid,$_);
-	     }
-	}
+        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)=@_;
+    my ($origcrsid,$newcrsid,$date_mode,$date_shift,$newinstcode,$newowner,
+        $tinyurls)=@_;
     &copyuserfiles($origcrsid,$newcrsid);
-    &copydbfiles($origcrsid,$newcrsid);
+    my @info = &copydbfiles($origcrsid,$newcrsid,$newinstcode,$newowner,$tinyurls);
     &copyresourcedb($origcrsid,$newcrsid,$date_mode,$date_shift);
-}
-
-sub copyroster {
-    my ($origcrsid,$newcrsid,$accessstart,$accessend) = @_;
-    my %origcrsdata=&Apache::lonnet::coursedescription($origcrsid);
-    my $newcrsiddata=&Apache::lonnet::coursedescription($newcrsid);
-
-    my $classlist = 
-        &Apache::loncoursedata::get_classlist($origcrsdata{'domain'},$origcrsdata{'num'});
-    my %origdate = &Apache::lonnet::get('environment',
-                      ['default_enrollment_end_date'],
-                      $origcrsdata{'domain'},$origcrsdata{'num'});
-
-    my $enddate = $origdate{'default_enrollment_end_date'};
-
-    my $sec_idx  = &Apache::loncoursedata::CL_SECTION();
-    my $status_idx   = &Apache::loncoursedata::CL_STATUS();
-    my $end_idx = &Apache::loncoursedata::CL_END();
-    my $start_idx = &Apache::loncoursedata::CL_START();
-
-    my (%newstudents,%rolesadded,$numadded);
-    my $numadded = 0;
-    my $classlist = &Apache::loncoursedata::get_classlist();
-    if (ref($classlist) eq 'HASH') {
-        foreach my $student (sort(keys(%{$classlist}))) {
-            my ($sname,$sdom) = split(/:/,$student);
-            next if ($classlist->{$student}->[$end_idx] eq '-1'
-                   || ($classlist->{$student}->[$start_idx] eq '-1'));
-            if (($classlist->{$student}->[$status_idx] eq 'Active') ||
-                ($classlist->{$student}->[$end_idx] >= $enddate)) {
-                if (ref($classlist->{$student}) eq 'ARRAY') {
-                    my @info = @{$classlist->{$student}};
-                    $info[$end_idx] = $accessend;
-                    $info[$start_idx] = $accessstart;
-                    $newstudents{$student}{'info'} = join(':',@info);
-                    $newstudents{$student}{'section'} = 
-                        $classlist->{$student}->[$sec_idx];
-                }
-            }
-        }
-    }
-    if (keys(%newstudents)) {
-        my $uurl='/'.$newcrsid;
-        $uurl=~s/\_/\//g;
-        foreach my $student (sort(keys(%newstudents))) {
-            my $surl = $uurl;  
-            if ($newstudents{$student}{'section'}) {
-                $surl.='/'.$newstudents{$student}{'section'};
-            }
-            if (&assignrole($sdom,$sname,$uurl,'st',$accessend,$accessstart,undef,undef,'requestcourses') eq 'ok') {
-                $rolesadded{$student} = $newstudents{$student};
-                $numadded ++ ;
-            }
-        }
-    }
-    my $clisterror;
-    if (keys(%rolesadded) > 0) {
-        my $reply=cput('classlist',\%rolesadded,$newcrsdata{'domain'},$newcrsdata{'num'});
-        unless (($reply eq 'ok') || ($reply eq 'delayed')) {
-            $clisterror = 'error: '.$reply;
-        }
-    }
-    return ($numadded,$clisterror);
+    return @info;
 }
 
 1;