Annotation of loncom/interface/lonclonecourse.pm, revision 1.17
1.1 albertel 1: # The LearningOnline Network
2: # routines for clone a course
3: #
1.17 ! raeburn 4: # $Id: lonclonecourse.pm,v 1.16 2020/07/23 18:03:10 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)=@_;
1.16 raeburn 111: unless ($which=~/\.(page|sequence)$/) {
1.1 albertel 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.17 ! raeburn 233: } elsif ($which eq 'lti') {
! 234: foreach my $key (keys($data)) {
! 235: if (ref($data{$key}) eq 'HASH') {
! 236: if (exists($data{$key}{'usable'})) {
! 237: delete($data{$key}{'usable'});
! 238: }
! 239: }
! 240: }
1.14 raeburn 241: }
1.15 raeburn 242: my $putres = &Apache::lonnet::put
243: ($which,\%data,$newcrsdata{'domain'},$newcrsdata{'num'});
244: return @info;
1.1 albertel 245: }
246:
247: # ========================================================== Copy resourcesdata
248:
249: sub copyresourcedb {
1.6 www 250: my ($origcrsid,$newcrsid,$date_mode,$date_shift)=@_;
251: my $delta=$date_shift*60*60*24;
1.1 albertel 252: my %origcrsdata=&Apache::lonnet::coursedescription($origcrsid);
253: my %newcrsdata= &Apache::lonnet::coursedescription($newcrsid);
1.12 raeburn 254: my $origtz;
255: if (($date_mode) && ($date_mode ne 'preserve') && ($date_shift) &&
256: (int($date_shift) == $date_shift)) {
257: $origtz = $origcrsdata{'timezone'};
258: if ($origtz eq '') {
259: my %domdefaults = &Apache::lonnet::get_domain_defaults($origcrsdata{'domain'});
260: if ($domdefaults{'timezone_def'} ne '') {
261: $origtz = $domdefaults{'timezone_def'};
262: }
263: }
264: if ($origtz eq '') {
265: $origtz = 'local';
266: } elsif (!DateTime::TimeZone->is_valid_name($origtz)) {
267: $origtz = 'local';
268: }
269: }
1.1 albertel 270: my %data=&Apache::lonnet::dump
271: ('resourcedata',$origcrsdata{'domain'},$origcrsdata{'num'});
272: $origcrsid=~s/^\///;
273: $origcrsid=~s/\//\_/;
274: $newcrsid=~s/^\///;
275: $newcrsid=~s/\//\_/;
276: my %newdata=();
277: undef %newdata;
278: my $startdate=$data{$origcrsid.'.0.opendate'};
279: if (!$startdate) {
280: # now global start date for assements try the enrollment start
281: my %start=&Apache::lonnet::get('environment',
282: ['default_enrollment_start_date'],
283: $origcrsdata{'domain'},$origcrsdata{'num'});
284:
285: $startdate = $start{'default_enrollment_start_date'};
286: }
287: # ugly retro fix for broken version of types
1.10 raeburn 288: foreach my $key (keys(%data)) {
1.6 www 289: if ($key=~/\wtype$/) {
290: my $newkey=$key;
1.1 albertel 291: $newkey=~s/type$/\.type/;
1.6 www 292: $data{$newkey}=$data{$key};
293: delete $data{$key};
1.1 albertel 294: }
295: }
296: # adjust symbs
297: my $pattern='uploaded/'.$origcrsdata{'domain'}.'/'.$origcrsdata{'num'}.'/';
298: my $new= 'uploaded/'. $newcrsdata{'domain'}.'/'. $newcrsdata{'num'}.'/';
1.10 raeburn 299: foreach my $key (keys(%data)) {
1.6 www 300: if ($key=~/\Q$pattern\E/) {
301: my $newkey=$key;
1.2 albertel 302: $newkey=~s/\Q$pattern\E/$new/;
1.6 www 303: $data{$newkey}=$data{$key};
304: delete $data{$key};
305: }
306: }
307: # transfer hash
1.10 raeburn 308: foreach my $key (keys(%data)) {
1.6 www 309: my $thiskey=$key;
310: $thiskey=~s/^$origcrsid/$newcrsid/;
311: $newdata{$thiskey}=$data{$key};
312: # date_mode empty or "preserve": transfer dates one-to-one
313: # date_mode "shift": shift dates by date_shift days
314: # date_mode other: do not transfer dates
315: if (($date_mode) && ($date_mode ne 'preserve')) {
316: if ($data{$key.'.type'}=~/^date_(start|end)$/) {
1.12 raeburn 317: if ($date_mode eq 'shift') {
318: if (($date_shift) && ($date_shift == int($date_shift))) {
319: my $dt = DateTime->from_epoch(epoch => $newdata{$thiskey})
320: ->set_time_zone($origtz);
321: if (($origtz eq 'local') && (!$ENV{TZ})) {
322: $ENV{TZ} = $dt->time_zone()->name();
323: }
1.13 raeburn 324: eval {
325: $dt->add(days => int($date_shift));
326: };
327: if ($@) {
328: $newdata{$thiskey} = $newdata{$thiskey}+$delta+(60*60);
329: } else {
330: $newdata{$thiskey} = $dt->epoch();
331: }
1.12 raeburn 332: } else {
333: $newdata{$thiskey} = $newdata{$thiskey}+$delta;
334: }
335: } else {
336: delete($newdata{$thiskey});
337: delete($newdata{$thiskey.'.type'});
338: }
1.6 www 339: }
1.12 raeburn 340: }
1.1 albertel 341: }
342: return &Apache::lonnet::put
343: ('resourcedata',\%newdata,$newcrsdata{'domain'},$newcrsdata{'num'});
344: }
345:
346: # ========================================================== Copy all userfiles
347:
348: sub copyuserfiles {
349: my ($origcrsid,$newcrsid)=@_;
350: foreach (&crsdirlist($origcrsid,'userfiles')) {
351: if ($_ !~m|^scantron_|) {
352: ©file($origcrsid,$newcrsid,$_);
353: }
354: }
1.15 raeburn 355: return;
1.1 albertel 356: }
357: # ========================================================== Copy all userfiles
358:
359: sub copydbfiles {
1.15 raeburn 360: my ($origcrsid,$newcrsid,$newinstcode,$newowner,$tinyurls)=@_;
361: my @copyinfo;
1.1 albertel 362:
363: my ($origcrs_discussion) = ($origcrsid=~m|^/(.*)|);
364: $origcrs_discussion=~s|/|_|g;
365: foreach (&crsdirlist($origcrsid)) {
1.15 raeburn 366: if ($_=~/\.db$/) {
367: unless ($_=~/^(nohist\_|disclikes|discussiontimes|classlist|versionupdate
368: |resourcedata|\Q$origcrs_discussion\E|slots|slot_reservations
369: |gradingqueue|reviewqueue|CODEs|groupmembership|comm_block)/) {
370: my @info = ©db($origcrsid,$newcrsid,$_,$newinstcode,$newowner,
371: $tinyurls);
372: if (@info) {
373: push(@copyinfo,@info);
374: }
375: }
1.11 musolffc 376: }
1.1 albertel 377: }
1.15 raeburn 378: return @copyinfo;
1.1 albertel 379: }
380:
381: # ======================================================= Copy all course files
382:
383: sub copycoursefiles {
1.15 raeburn 384: my ($origcrsid,$newcrsid,$date_mode,$date_shift,$newinstcode,$newowner,
385: $tinyurls)=@_;
1.1 albertel 386: ©userfiles($origcrsid,$newcrsid);
1.15 raeburn 387: my @info = ©dbfiles($origcrsid,$newcrsid,$newinstcode,$newowner,$tinyurls);
1.6 www 388: ©resourcedb($origcrsid,$newcrsid,$date_mode,$date_shift);
1.15 raeburn 389: return @info;
1.1 albertel 390: }
391:
392: 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