Annotation of loncom/interface/lonclonecourse.pm, revision 1.9
1.1 albertel 1: # The LearningOnline Network
2: # routines for clone a course
3: #
1.9 ! raeburn 4: # $Id: lonclonecourse.pm,v 1.8 2011/10/17 12:41:30 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;
33:
34: # ================================================ Get course directory listing
35:
36: my @output=();
37:
38: sub crsdirlist {
39: my ($courseid,$which)=@_;
40: @output=();
41: return &innercrsdirlist($courseid,$which);
42: }
43:
44: sub innercrsdirlist {
45: my ($courseid,$which,$path)=@_;
46: my $dirptr=16384;
47: unless ($which) { $which=''; } else { $which.='/'; }
48: unless ($path) { $path=''; } else { $path.='/'; }
49: my %crsdata=&Apache::lonnet::coursedescription($courseid);
1.7 raeburn 50: my $getpropath = 1;
1.8 raeburn 51: my ($dirlistref,$listerror) =
52: &Apache::lonnet::dirlist($which,$crsdata{'domain'},
53: $crsdata{'num'},$getpropath);
54: if (ref($dirlistref) eq 'ARRAY') {
55: foreach (@{$dirlistref}) {
56: unless ($_=~/^\./) {
57: my @unpackline = split (/\&/,$_);
58: if ($unpackline[3]&$dirptr) {
1.1 albertel 59: # is a directory, recurse
1.8 raeburn 60: &innercrsdirlist($courseid,$which.$unpackline[0],
61: $path.$unpackline[0]);
62: } else {
1.1 albertel 63: # is a file, put into output
1.8 raeburn 64: push (@output,$path.$unpackline[0]);
65: }
1.1 albertel 66: }
1.8 raeburn 67: }
1.1 albertel 68: }
69: return @output;
70: }
71:
72: # ============================================================= Read a userfile
73:
74: sub readfile {
75: my ($courseid,$which)=@_;
76: my %crsdata=&Apache::lonnet::coursedescription($courseid);
77: my $file = &Apache::lonnet::getfile('/uploaded/'.$crsdata{'domain'}.'/'.
78: $crsdata{'num'}.'/'.$which);
79: return $file;
80: }
81:
82: # ============================================================ Write a userfile
83:
84: sub writefile {
85: (my $courseid, my $which,$env{'form.output'})=@_;
86: my %crsdata=&Apache::lonnet::coursedescription($courseid);
87: my $data = &Apache::lonnet::finishuserfileupload(
88: $crsdata{'num'},$crsdata{'domain'},
89: 'output',$which);
90: return $data;
91: }
92:
93: # ===================================================================== Rewrite
94:
95: sub rewritefile {
96: my ($contents,%rewritehash)=@_;
1.2 albertel 97: foreach my $pattern (keys(%rewritehash)) {
98: my $new=$rewritehash{$pattern};
99: $contents=~s/\Q$pattern\E/$new/gs;
1.1 albertel 100: }
101: return $contents;
102: }
103:
104: # ============================================================= Copy a userfile
105:
106: sub copyfile {
107: my ($origcrsid,$newcrsid,$which)=@_;
108: unless ($which=~/\.sequence$/) {
109: return &writefile($newcrsid,$which,
110: &readfile($origcrsid,$which));
111: } else {
112: my %origcrsdata=&Apache::lonnet::coursedescription($origcrsid);
113: my %newcrsdata= &Apache::lonnet::coursedescription($newcrsid);
114: return &writefile($newcrsid,$which,
115: &rewritefile(
116: &readfile($origcrsid,$which),
117: (
118: '/uploaded/'.$origcrsdata{'domain'}.'/'.$origcrsdata{'num'}.'/'
119: => '/uploaded/'. $newcrsdata{'domain'}.'/'. $newcrsdata{'num'}.'/',
120: '/public/'.$origcrsdata{'domain'}.'/'.$origcrsdata{'num'}.'/'
1.4 raeburn 121: => '/public/'. $newcrsdata{'domain'}.'/'. $newcrsdata{'num'}.'/',
122: '/adm/'.$origcrsdata{'domain'}.'/'.$origcrsdata{'num'}.'/'
123: => '/adm/'.$newcrsdata{'domain'}.'/'.$newcrsdata{'num'}.'/',
1.1 albertel 124: )));
125: }
126: }
127:
128: # =============================================================== Copy a dbfile
129:
130: sub copydb {
131: my ($origcrsid,$newcrsid,$which)=@_;
132: $which=~s/\.db$//;
133: my %origcrsdata=&Apache::lonnet::coursedescription($origcrsid);
134: my %newcrsdata= &Apache::lonnet::coursedescription($newcrsid);
135: my %data=&Apache::lonnet::dump
136: ($which,$origcrsdata{'domain'},$origcrsdata{'num'});
137: foreach my $key (keys(%data)) {
138: if ($key=~/^internal./) { delete($data{$key}); }
139: }
140: return &Apache::lonnet::put
141: ($which,\%data,$newcrsdata{'domain'},$newcrsdata{'num'});
142: }
143:
144: # ========================================================== Copy resourcesdata
145:
146: sub copyresourcedb {
1.6 www 147: my ($origcrsid,$newcrsid,$date_mode,$date_shift)=@_;
148: my $delta=$date_shift*60*60*24;
1.1 albertel 149: my %origcrsdata=&Apache::lonnet::coursedescription($origcrsid);
150: my %newcrsdata= &Apache::lonnet::coursedescription($newcrsid);
151: my %data=&Apache::lonnet::dump
152: ('resourcedata',$origcrsdata{'domain'},$origcrsdata{'num'});
153: $origcrsid=~s/^\///;
154: $origcrsid=~s/\//\_/;
155: $newcrsid=~s/^\///;
156: $newcrsid=~s/\//\_/;
157: my %newdata=();
158: undef %newdata;
159: my $startdate=$data{$origcrsid.'.0.opendate'};
160: if (!$startdate) {
161: # now global start date for assements try the enrollment start
162: my %start=&Apache::lonnet::get('environment',
163: ['default_enrollment_start_date'],
164: $origcrsdata{'domain'},$origcrsdata{'num'});
165:
166: $startdate = $start{'default_enrollment_start_date'};
167: }
168: # ugly retro fix for broken version of types
1.6 www 169: foreach my $key (keys %data) {
170: if ($key=~/\wtype$/) {
171: my $newkey=$key;
1.1 albertel 172: $newkey=~s/type$/\.type/;
1.6 www 173: $data{$newkey}=$data{$key};
174: delete $data{$key};
1.1 albertel 175: }
176: }
177: # adjust symbs
178: my $pattern='uploaded/'.$origcrsdata{'domain'}.'/'.$origcrsdata{'num'}.'/';
179: my $new= 'uploaded/'. $newcrsdata{'domain'}.'/'. $newcrsdata{'num'}.'/';
1.6 www 180: foreach my $key (keys %data) {
181: if ($key=~/\Q$pattern\E/) {
182: my $newkey=$key;
1.2 albertel 183: $newkey=~s/\Q$pattern\E/$new/;
1.6 www 184: $data{$newkey}=$data{$key};
185: delete $data{$key};
186: }
187: }
188: # transfer hash
189: foreach my $key (keys %data) {
190: my $thiskey=$key;
191: $thiskey=~s/^$origcrsid/$newcrsid/;
192: $newdata{$thiskey}=$data{$key};
193: # date_mode empty or "preserve": transfer dates one-to-one
194: # date_mode "shift": shift dates by date_shift days
195: # date_mode other: do not transfer dates
196: if (($date_mode) && ($date_mode ne 'preserve')) {
197: if ($data{$key.'.type'}=~/^date_(start|end)$/) {
198: if ($date_mode eq 'shift') {
199: $newdata{$thiskey}=$newdata{$thiskey}+$delta;
200: } else {
201: delete($newdata{$thiskey});
202: delete($newdata{$thiskey.'.type'});
203: }
204: }
1.1 albertel 205: }
206: }
207: return &Apache::lonnet::put
208: ('resourcedata',\%newdata,$newcrsdata{'domain'},$newcrsdata{'num'});
209: }
210:
211: # ========================================================== Copy all userfiles
212:
213: sub copyuserfiles {
214: my ($origcrsid,$newcrsid)=@_;
215: foreach (&crsdirlist($origcrsid,'userfiles')) {
216: if ($_ !~m|^scantron_|) {
217: ©file($origcrsid,$newcrsid,$_);
218: }
219: }
220: }
221: # ========================================================== Copy all userfiles
222:
223: sub copydbfiles {
224: my ($origcrsid,$newcrsid)=@_;
225:
226: my ($origcrs_discussion) = ($origcrsid=~m|^/(.*)|);
227: $origcrs_discussion=~s|/|_|g;
228: foreach (&crsdirlist($origcrsid)) {
229: if ($_=~/\.db$/) {
230: unless
1.9 ! raeburn 231: ($_=~/^(nohist\_|disclikes|discussiontimes|classlist|versionupdate|resourcedata|\Q$origcrs_discussion\E|slots|slot_reservations|gradingqueue|reviewqueue|CODEs|groupmembership)/) {
1.1 albertel 232: ©db($origcrsid,$newcrsid,$_);
233: }
234: }
235: }
236: }
237:
238: # ======================================================= Copy all course files
239:
240: sub copycoursefiles {
1.6 www 241: my ($origcrsid,$newcrsid,$date_mode,$date_shift)=@_;
1.1 albertel 242: ©userfiles($origcrsid,$newcrsid);
243: ©dbfiles($origcrsid,$newcrsid);
1.6 www 244: ©resourcedb($origcrsid,$newcrsid,$date_mode,$date_shift);
1.1 albertel 245: }
246:
247: 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