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: ©file($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 = ©db($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: ©userfiles($origcrsid,$newcrsid);
1.15 ! raeburn 379: my @info = ©dbfiles($origcrsid,$newcrsid,$newinstcode,$newowner,$tinyurls);
1.6 www 380: ©resourcedb($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>
![[BACK]](/icons/back.gif){kind=icon}
Return to lonclonecourse.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / interface