Annotation of loncom/interface/lonclonecourse.pm, revision 1.15

1.1       albertel    1: # The LearningOnline Network
                      2: # routines for clone a course
                      3: #
1.15    ! raeburn     4: # $Id: lonclonecourse.pm,v 1.14 2020/06/01 20:35:02 raeburn Exp $
1.1       albertel    5: #
                      6: # Copyright Michigan State University Board of Trustees
                      7: #
                      8: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
                      9: #
                     10: # LON-CAPA is free software; you can redistribute it and/or modify
                     11: # it under the terms of the GNU General Public License as published by
                     12: # the Free Software Foundation; either version 2 of the License, or
                     13: # (at your option) any later version.
                     14: #
                     15: # LON-CAPA is distributed in the hope that it will be useful,
                     16: # but WITHOUT ANY WARRANTY; without even the implied warranty of
                     17: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
                     18: # GNU General Public License for more details.
                     19: #
                     20: # You should have received a copy of the GNU General Public License
                     21: # along with LON-CAPA; if not, write to the Free Software
                     22: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
                     23: #
                     24: # /home/httpd/html/adm/gpl.txt
                     25: #
                     26: # http://www.lon-capa.org/
                     27: #
                     28: ###
                     29: 
                     30: package Apache::lonclonecourse;
                     31: use LONCAPA;
                     32: use Apache::lonnet;
1.15    ! raeburn    33: use Apache::lonlocal;
1.12      raeburn    34: use DateTime();
                     35: use DateTime::TimeZone;
1.1       albertel   36: 
                     37: # ================================================ Get course directory listing
                     38: 
                     39: my @output=();
                     40: 
                     41: sub crsdirlist {
                     42:     my ($courseid,$which)=@_;
                     43:     @output=();
                     44:     return &innercrsdirlist($courseid,$which);
                     45: }
                     46: 
                     47: sub innercrsdirlist {
                     48:     my ($courseid,$which,$path)=@_;
                     49:     my $dirptr=16384;
                     50:     unless ($which) { $which=''; } else { $which.='/'; }
                     51:     unless ($path)  { $path=''; } else { $path.='/'; }
                     52:     my %crsdata=&Apache::lonnet::coursedescription($courseid);
1.7       raeburn    53:     my $getpropath = 1;
1.8       raeburn    54:     my ($dirlistref,$listerror) = 
                     55:         &Apache::lonnet::dirlist($which,$crsdata{'domain'},
                     56:                                  $crsdata{'num'},$getpropath);
                     57:     if (ref($dirlistref) eq 'ARRAY') {
                     58:         foreach (@{$dirlistref}) {
                     59: 	    unless ($_=~/^\./) {
                     60: 	        my @unpackline = split (/\&/,$_);
                     61: 	        if ($unpackline[3]&$dirptr) {
1.1       albertel   62: # is a directory, recurse
1.8       raeburn    63: 		    &innercrsdirlist($courseid,$which.$unpackline[0],
                     64: 				     $path.$unpackline[0]);
                     65: 	        } else { 
1.1       albertel   66: # is a file, put into output
1.8       raeburn    67: 		    push (@output,$path.$unpackline[0]);
                     68: 	        }
1.1       albertel   69: 	    }
1.8       raeburn    70:         }
1.1       albertel   71:     }
                     72:     return @output;
                     73: }
                     74: 
                     75: # ============================================================= Read a userfile
                     76: 
                     77: sub readfile {
                     78:     my ($courseid,$which)=@_;
                     79:     my %crsdata=&Apache::lonnet::coursedescription($courseid);
                     80:     my $file = &Apache::lonnet::getfile('/uploaded/'.$crsdata{'domain'}.'/'.
                     81: 				      $crsdata{'num'}.'/'.$which);
                     82:     return $file;
                     83: }
                     84: 
                     85: # ============================================================ Write a userfile
                     86: 
                     87: sub writefile {
                     88:     (my $courseid, my $which,$env{'form.output'})=@_;
                     89:     my %crsdata=&Apache::lonnet::coursedescription($courseid);
                     90:     my $data = &Apache::lonnet::finishuserfileupload(
                     91: 					  $crsdata{'num'},$crsdata{'domain'},
                     92: 					  'output',$which);
                     93:     return $data;
                     94: }
                     95: 
                     96: # ===================================================================== Rewrite
                     97: 
                     98: sub rewritefile {
                     99:     my ($contents,%rewritehash)=@_;
1.2       albertel  100:     foreach my $pattern (keys(%rewritehash)) {
                    101: 	my $new=$rewritehash{$pattern};
                    102: 	$contents=~s/\Q$pattern\E/$new/gs;
1.1       albertel  103:     }
                    104:     return $contents;
                    105: }
                    106: 
                    107: # ============================================================= Copy a userfile
                    108: 
                    109: sub copyfile {
                    110:     my ($origcrsid,$newcrsid,$which)=@_;
                    111:     unless ($which=~/\.sequence$/) {
                    112: 	return &writefile($newcrsid,$which,
                    113: 		      &readfile($origcrsid,$which));
                    114:     } else {
                    115: 	my %origcrsdata=&Apache::lonnet::coursedescription($origcrsid);
                    116: 	my %newcrsdata= &Apache::lonnet::coursedescription($newcrsid);
                    117: 	return &writefile($newcrsid,$which,
                    118: 		 &rewritefile(
                    119:                      &readfile($origcrsid,$which),
                    120: 	    (
                    121:        '/uploaded/'.$origcrsdata{'domain'}.'/'.$origcrsdata{'num'}.'/'
                    122:     => '/uploaded/'. $newcrsdata{'domain'}.'/'. $newcrsdata{'num'}.'/',
                    123:        '/public/'.$origcrsdata{'domain'}.'/'.$origcrsdata{'num'}.'/'
1.4       raeburn   124:     => '/public/'. $newcrsdata{'domain'}.'/'. $newcrsdata{'num'}.'/',
                    125:        '/adm/'.$origcrsdata{'domain'}.'/'.$origcrsdata{'num'}.'/'
                    126:     => '/adm/'.$newcrsdata{'domain'}.'/'.$newcrsdata{'num'}.'/',
1.1       albertel  127:             )));
                    128:     }
                    129: }
                    130: 
                    131: # =============================================================== Copy a dbfile
                    132: 
                    133: sub copydb {
1.15    ! raeburn   134:     my ($origcrsid,$newcrsid,$which,$newinstcode,$newowner,$tinyurls)=@_;
1.1       albertel  135:     $which=~s/\.db$//;
                    136:     my %origcrsdata=&Apache::lonnet::coursedescription($origcrsid);
                    137:     my %newcrsdata= &Apache::lonnet::coursedescription($newcrsid);
1.15    ! raeburn   138:     if (($which eq 'tiny') && ($tinyurls eq 'delete')) {
        !           139:         return ();
        !           140:     }
        !           141:     my @info;
1.1       albertel  142:     my %data=&Apache::lonnet::dump
                    143: 	($which,$origcrsdata{'domain'},$origcrsdata{'num'});
                    144:     foreach my $key (keys(%data)) {
                    145: 	if ($key=~/^internal./) { delete($data{$key}); }
                    146:     }
1.14      raeburn   147:     if ($which =~ /^exttool_\d+$/) {
                    148:         if ($origcrsdata{'description'} ne $newcrsdata{'description'}) {
                    149:             $data{'crstitle'} =~s/\Q$origcrsdata{'description'}\E/$newcrsdata{'description'}/;
                    150:         }
                    151:         if ($origcrsdata{'internal.coursecode'} ne $newinstcode) {
                    152:             $data{'crslabel'} =~ s/\Q$origcrsdata{'internal.coursecode'}\E/$newinstcode/;
                    153:         }
1.15    ! raeburn   154:     } elsif ($which eq 'tiny') {
        !           155:         my $oldprefix = 'uploaded/'.$origcrsdata{'domain'}.'/'.$origcrsdata{'num'}.'/';
        !           156:         my $newprefix = 'uploaded/'.$newcrsdata{'domain'}.'/'. $newcrsdata{'num'}.'/';
        !           157:         my (%domtiny,%tocreate,@todelete,$numnew,$errors);
        !           158:         if (($tinyurls eq 'transfer') && (keys(%data))) {
        !           159:             unless (($origcrsdata{'internal.courseowner'} eq $newowner) &&
        !           160:                     ($origcrsdata{'domain'} eq $newcrsdata{'domain'})) {
        !           161:                 $tinyurls = 'create';
        !           162:                 push(@info,{
        !           163:                              mt => "Action for URL shortcut(s) changed from 'transfer' to 'create' ".
        !           164:                                    "because requirements of same owner and some course domain ".
        !           165:                                    "for new course and original course not met.",
        !           166:                              args => [],
        !           167:                            });
        !           168:             }
        !           169:         }
        !           170:         foreach my $key (keys(%data)) {
        !           171:             my $code = $data{$key};
        !           172:             my $newkey = $key;
        !           173:             $newkey =~ s{\Q$oldprefix\E}{$newprefix}g;
        !           174:             if ($tinyurls eq 'transfer') {
        !           175:                 $data{$newkey} = $code;
        !           176:                 $domtiny{$code} = $newcrsdata{'num'}.'&'.$newkey;
        !           177:                 push(@todelete,$key);
        !           178:             } else {
        !           179:                 $tocreate{$newcrsdata{'num'}.'&'.$newkey} = 1;
        !           180:             }
        !           181:             delete($data{$key});
        !           182:         }
        !           183:         if (keys(%tocreate)) {
        !           184:             ($numnew,$errors) = &Apache::loncommon::make_short_symbs($newcrsdata{'domain'},
        !           185:                                                                      $newcrsdata{'num'},
        !           186:                                                                      \%tocreate,$newowner);
        !           187:             if ((ref($errors) eq 'ARRAY') && (@{$errors} > 0)) {
        !           188:                 push(@info,{
        !           189:                             mt => 'Error(s) when creating URL shortcut(s) in new course for equivalent '.
        !           190:                                   'resource(s)/folder(s) in original course: [_1]',
        !           191:                             args => [join(', ',@{$errors})],
        !           192:                            });
        !           193:             }
        !           194:             if ($numnew) {
        !           195:                 push(@info,{
        !           196:                             mt => 'New URL shortcut(s) in new course for [quant,_1,item] to replicate '.
        !           197:                                   'shortcut(s) for equivalent(s) in original course.',
        !           198:                             args => [$numnew],
        !           199:                            });
        !           200:             }
        !           201:             return @info;
        !           202:         } elsif (keys(%domtiny)) {
        !           203:             my $configuname = &Apache::lonnet::get_domainconfiguser($newcrsdata{'domain'});
        !           204:             my $putdomres = &Apache::lonnet::put('tiny',\%domtiny,$newcrsdata{'domain'},$configuname);
        !           205:             if ($putdomres eq 'ok') {
        !           206:                 my $delres = &Apache::lonnet::del('tiny',\@todelete,
        !           207:                                                  $origcrsdata{'domain'},
        !           208:                                                  $origcrsdata{'num'});
        !           209: 
        !           210:                 if ($delres eq 'ok') {
        !           211:                     push(@info,{
        !           212:                                  mt => 'URL shortcut(s) for [quant,_1,item] transferred, and '.
        !           213:                                        'now point to resource(s)/folder(s) in new course instead of '.
        !           214:                                        'equivalent(s) in original course.',
        !           215:                                  args => [scalar(keys(%domtiny))],
        !           216:                                });
        !           217:                 } else {
        !           218:                     push(@info,{
        !           219:                                  mt => 'Failed to delete URL shortcut(s) in original course '.
        !           220:                                        'when attempting to transfer to new course.',
        !           221:                                  args => [],
        !           222:                                });
        !           223:                 }
        !           224:             } else {
        !           225:                 push(@info,{
        !           226:                               mt => 'Failed to store update of target course for URL shortcut(s) in '.
        !           227:                                     'domain records.',
        !           228:                               args => [],
        !           229:                            });
        !           230:                 return @info;
        !           231:             }
        !           232:         }
1.14      raeburn   233:     }
1.15    ! raeburn   234:     my $putres = &Apache::lonnet::put
        !           235:                      ($which,\%data,$newcrsdata{'domain'},$newcrsdata{'num'});
        !           236:     return @info;
1.1       albertel  237: }
                    238: 
                    239: # ========================================================== Copy resourcesdata
                    240: 
                    241: sub copyresourcedb {
1.6       www       242:     my ($origcrsid,$newcrsid,$date_mode,$date_shift)=@_;
                    243:     my $delta=$date_shift*60*60*24;
1.1       albertel  244:     my %origcrsdata=&Apache::lonnet::coursedescription($origcrsid);
                    245:     my %newcrsdata= &Apache::lonnet::coursedescription($newcrsid);
1.12      raeburn   246:     my $origtz;
                    247:     if (($date_mode) && ($date_mode ne 'preserve') && ($date_shift) && 
                    248:         (int($date_shift) == $date_shift)) {
                    249:         $origtz = $origcrsdata{'timezone'};
                    250:         if ($origtz eq '') {
                    251:             my %domdefaults = &Apache::lonnet::get_domain_defaults($origcrsdata{'domain'});
                    252:             if ($domdefaults{'timezone_def'} ne '') {
                    253:                 $origtz = $domdefaults{'timezone_def'};
                    254:             }
                    255:         }
                    256:         if ($origtz eq '') {
                    257:             $origtz = 'local';
                    258:         } elsif (!DateTime::TimeZone->is_valid_name($origtz)) {
                    259:             $origtz = 'local';
                    260:         }
                    261:     }
1.1       albertel  262:     my %data=&Apache::lonnet::dump
                    263: 	('resourcedata',$origcrsdata{'domain'},$origcrsdata{'num'});
                    264:     $origcrsid=~s/^\///;
                    265:     $origcrsid=~s/\//\_/;
                    266:     $newcrsid=~s/^\///;
                    267:     $newcrsid=~s/\//\_/;
                    268:     my %newdata=();
                    269:     undef %newdata;
                    270:     my $startdate=$data{$origcrsid.'.0.opendate'};
                    271:     if (!$startdate) {
                    272: 	# now global start date for assements try the enrollment start
                    273: 	my %start=&Apache::lonnet::get('environment',
                    274: 				   ['default_enrollment_start_date'],
                    275: 				   $origcrsdata{'domain'},$origcrsdata{'num'});
                    276: 
                    277: 	$startdate = $start{'default_enrollment_start_date'};
                    278:     }
                    279: # ugly retro fix for broken version of types
1.10      raeburn   280:     foreach my $key (keys(%data)) {
1.6       www       281: 	if ($key=~/\wtype$/) {
                    282: 	    my $newkey=$key;
1.1       albertel  283: 	    $newkey=~s/type$/\.type/;
1.6       www       284: 	    $data{$newkey}=$data{$key};
                    285: 	    delete $data{$key};
1.1       albertel  286: 	}
                    287:     }
                    288: # adjust symbs
                    289:     my $pattern='uploaded/'.$origcrsdata{'domain'}.'/'.$origcrsdata{'num'}.'/';
                    290:     my $new=    'uploaded/'. $newcrsdata{'domain'}.'/'. $newcrsdata{'num'}.'/';
1.10      raeburn   291:     foreach my $key (keys(%data)) {
1.6       www       292: 	if ($key=~/\Q$pattern\E/) {
                    293: 	    my $newkey=$key;
1.2       albertel  294: 	    $newkey=~s/\Q$pattern\E/$new/;
1.6       www       295: 	    $data{$newkey}=$data{$key};
                    296: 	    delete $data{$key};
                    297: 	}
                    298:     }
                    299: #  transfer hash
1.10      raeburn   300:     foreach my $key (keys(%data)) {
1.6       www       301: 	my $thiskey=$key;
                    302: 	$thiskey=~s/^$origcrsid/$newcrsid/;
                    303: 	$newdata{$thiskey}=$data{$key};
                    304: # date_mode empty or "preserve": transfer dates one-to-one
                    305: # date_mode "shift": shift dates by date_shift days
                    306: # date_mode other: do not transfer dates
                    307:         if (($date_mode) && ($date_mode ne 'preserve')) {
                    308: 	    if ($data{$key.'.type'}=~/^date_(start|end)$/) {
1.12      raeburn   309: 	        if ($date_mode eq 'shift') {
                    310:                     if (($date_shift) && ($date_shift == int($date_shift))) { 
                    311:                         my $dt = DateTime->from_epoch(epoch => $newdata{$thiskey})
                    312:                                                       ->set_time_zone($origtz);
                    313:                         if (($origtz eq 'local') && (!$ENV{TZ})) {
                    314:                             $ENV{TZ} = $dt->time_zone()->name();
                    315:                         }
1.13      raeburn   316:                         eval {
                    317:                             $dt->add(days => int($date_shift));
                    318:                         };
                    319:                         if ($@) {
                    320:                             $newdata{$thiskey} = $newdata{$thiskey}+$delta+(60*60);
                    321:                         } else {
                    322:                             $newdata{$thiskey} = $dt->epoch();
                    323:                         }
1.12      raeburn   324:                     } else {
                    325:                         $newdata{$thiskey} = $newdata{$thiskey}+$delta;
                    326:                     }
                    327:                 } else {
                    328:                     delete($newdata{$thiskey});
                    329:                     delete($newdata{$thiskey.'.type'});
                    330:                 }
1.6       www       331:             }
1.12      raeburn   332:         }
1.1       albertel  333:     }
                    334:     return &Apache::lonnet::put
                    335: 	('resourcedata',\%newdata,$newcrsdata{'domain'},$newcrsdata{'num'});
                    336: }
                    337: 
                    338: # ========================================================== Copy all userfiles
                    339: 
                    340: sub copyuserfiles {
                    341:     my ($origcrsid,$newcrsid)=@_;
                    342:     foreach (&crsdirlist($origcrsid,'userfiles')) {
                    343: 	if ($_ !~m|^scantron_|) {
                    344: 	    &copyfile($origcrsid,$newcrsid,$_);
                    345: 	}
                    346:     }
1.15    ! raeburn   347:     return;
1.1       albertel  348: }
                    349: # ========================================================== Copy all userfiles
                    350: 
                    351: sub copydbfiles {
1.15    ! raeburn   352:     my ($origcrsid,$newcrsid,$newinstcode,$newowner,$tinyurls)=@_;
        !           353:     my @copyinfo;
1.1       albertel  354: 
                    355:     my ($origcrs_discussion) = ($origcrsid=~m|^/(.*)|);
                    356:     $origcrs_discussion=~s|/|_|g;
                    357:     foreach (&crsdirlist($origcrsid)) {
1.15    ! raeburn   358:         if ($_=~/\.db$/) {
        !           359:             unless ($_=~/^(nohist\_|disclikes|discussiontimes|classlist|versionupdate
        !           360:                    |resourcedata|\Q$origcrs_discussion\E|slots|slot_reservations
        !           361:                    |gradingqueue|reviewqueue|CODEs|groupmembership|comm_block)/) {
        !           362:                 my @info = &copydb($origcrsid,$newcrsid,$_,$newinstcode,$newowner,
        !           363:                                    $tinyurls);
        !           364:                 if (@info) {
        !           365:                     push(@copyinfo,@info);
        !           366:                 }
        !           367:             }
1.11      musolffc  368:         }
1.1       albertel  369:     }
1.15    ! raeburn   370:     return @copyinfo;
1.1       albertel  371: }
                    372: 
                    373: # ======================================================= Copy all course files
                    374: 
                    375: sub copycoursefiles {
1.15    ! raeburn   376:     my ($origcrsid,$newcrsid,$date_mode,$date_shift,$newinstcode,$newowner,
        !           377:         $tinyurls)=@_;
1.1       albertel  378:     &copyuserfiles($origcrsid,$newcrsid);
1.15    ! raeburn   379:     my @info = &copydbfiles($origcrsid,$newcrsid,$newinstcode,$newowner,$tinyurls);
1.6       www       380:     &copyresourcedb($origcrsid,$newcrsid,$date_mode,$date_shift);
1.15    ! raeburn   381:     return @info;
1.1       albertel  382: }
                    383: 
                    384: 1;

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>