Annotation of loncom/interface/lonclonecourse.pm, revision 1.7.12.1
1.1 albertel 1: # The LearningOnline Network
2: # routines for clone a course
3: #
1.7.12.1! raeburn 4: # $Id: lonclonecourse.pm,v 1.7 2008/09/11 13:19:28 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.7.12.1! raeburn 33: use Apache::loncoursedata;
1.1 albertel 34:
35: # ================================================ Get course directory listing
36:
37: my @output=();
38:
39: sub crsdirlist {
40: my ($courseid,$which)=@_;
41: @output=();
42: return &innercrsdirlist($courseid,$which);
43: }
44:
45: sub innercrsdirlist {
46: my ($courseid,$which,$path)=@_;
47: my $dirptr=16384;
48: unless ($which) { $which=''; } else { $which.='/'; }
49: unless ($path) { $path=''; } else { $path.='/'; }
50: my %crsdata=&Apache::lonnet::coursedescription($courseid);
1.7 raeburn 51: my $getpropath = 1;
1.1 albertel 52: my @listing=&Apache::lonnet::dirlist
1.7 raeburn 53: ($which,$crsdata{'domain'},$crsdata{'num'},$getpropath);
1.1 albertel 54: foreach (@listing) {
55: unless ($_=~/^\./) {
56: my @unpackline = split (/\&/,$_);
57: if ($unpackline[3]&$dirptr) {
58: # is a directory, recurse
59: &innercrsdirlist($courseid,$which.$unpackline[0],
60: $path.$unpackline[0]);
61: } else {
62: # is a file, put into output
63: push (@output,$path.$unpackline[0]);
64: }
65: }
66: }
67: return @output;
68: }
69:
70: # ============================================================= Read a userfile
71:
72: sub readfile {
73: my ($courseid,$which)=@_;
74: my %crsdata=&Apache::lonnet::coursedescription($courseid);
75: my $file = &Apache::lonnet::getfile('/uploaded/'.$crsdata{'domain'}.'/'.
76: $crsdata{'num'}.'/'.$which);
77: return $file;
78: }
79:
80: # ============================================================ Write a userfile
81:
82: sub writefile {
83: (my $courseid, my $which,$env{'form.output'})=@_;
84: my %crsdata=&Apache::lonnet::coursedescription($courseid);
85: my $data = &Apache::lonnet::finishuserfileupload(
86: $crsdata{'num'},$crsdata{'domain'},
87: 'output',$which);
88: return $data;
89: }
90:
91: # ===================================================================== Rewrite
92:
93: sub rewritefile {
94: my ($contents,%rewritehash)=@_;
1.2 albertel 95: foreach my $pattern (keys(%rewritehash)) {
96: my $new=$rewritehash{$pattern};
97: $contents=~s/\Q$pattern\E/$new/gs;
1.1 albertel 98: }
99: return $contents;
100: }
101:
102: # ============================================================= Copy a userfile
103:
104: sub copyfile {
105: my ($origcrsid,$newcrsid,$which)=@_;
106: unless ($which=~/\.sequence$/) {
107: return &writefile($newcrsid,$which,
108: &readfile($origcrsid,$which));
109: } else {
110: my %origcrsdata=&Apache::lonnet::coursedescription($origcrsid);
111: my %newcrsdata= &Apache::lonnet::coursedescription($newcrsid);
112: return &writefile($newcrsid,$which,
113: &rewritefile(
114: &readfile($origcrsid,$which),
115: (
116: '/uploaded/'.$origcrsdata{'domain'}.'/'.$origcrsdata{'num'}.'/'
117: => '/uploaded/'. $newcrsdata{'domain'}.'/'. $newcrsdata{'num'}.'/',
118: '/public/'.$origcrsdata{'domain'}.'/'.$origcrsdata{'num'}.'/'
1.4 raeburn 119: => '/public/'. $newcrsdata{'domain'}.'/'. $newcrsdata{'num'}.'/',
120: '/adm/'.$origcrsdata{'domain'}.'/'.$origcrsdata{'num'}.'/'
121: => '/adm/'.$newcrsdata{'domain'}.'/'.$newcrsdata{'num'}.'/',
1.1 albertel 122: )));
123: }
124: }
125:
126: # =============================================================== Copy a dbfile
127:
128: sub copydb {
129: my ($origcrsid,$newcrsid,$which)=@_;
130: $which=~s/\.db$//;
131: my %origcrsdata=&Apache::lonnet::coursedescription($origcrsid);
132: my %newcrsdata= &Apache::lonnet::coursedescription($newcrsid);
133: my %data=&Apache::lonnet::dump
134: ($which,$origcrsdata{'domain'},$origcrsdata{'num'});
135: foreach my $key (keys(%data)) {
136: if ($key=~/^internal./) { delete($data{$key}); }
137: }
138: return &Apache::lonnet::put
139: ($which,\%data,$newcrsdata{'domain'},$newcrsdata{'num'});
140: }
141:
142: # ========================================================== Copy resourcesdata
143:
144: sub copyresourcedb {
1.6 www 145: my ($origcrsid,$newcrsid,$date_mode,$date_shift)=@_;
146: my $delta=$date_shift*60*60*24;
1.1 albertel 147: my %origcrsdata=&Apache::lonnet::coursedescription($origcrsid);
148: my %newcrsdata= &Apache::lonnet::coursedescription($newcrsid);
149: my %data=&Apache::lonnet::dump
150: ('resourcedata',$origcrsdata{'domain'},$origcrsdata{'num'});
151: $origcrsid=~s/^\///;
152: $origcrsid=~s/\//\_/;
153: $newcrsid=~s/^\///;
154: $newcrsid=~s/\//\_/;
155: my %newdata=();
156: undef %newdata;
157: my $startdate=$data{$origcrsid.'.0.opendate'};
158: if (!$startdate) {
159: # now global start date for assements try the enrollment start
160: my %start=&Apache::lonnet::get('environment',
161: ['default_enrollment_start_date'],
162: $origcrsdata{'domain'},$origcrsdata{'num'});
163:
164: $startdate = $start{'default_enrollment_start_date'};
165: }
166: # ugly retro fix for broken version of types
1.6 www 167: foreach my $key (keys %data) {
168: if ($key=~/\wtype$/) {
169: my $newkey=$key;
1.1 albertel 170: $newkey=~s/type$/\.type/;
1.6 www 171: $data{$newkey}=$data{$key};
172: delete $data{$key};
1.1 albertel 173: }
174: }
175: # adjust symbs
176: my $pattern='uploaded/'.$origcrsdata{'domain'}.'/'.$origcrsdata{'num'}.'/';
177: my $new= 'uploaded/'. $newcrsdata{'domain'}.'/'. $newcrsdata{'num'}.'/';
1.6 www 178: foreach my $key (keys %data) {
179: if ($key=~/\Q$pattern\E/) {
180: my $newkey=$key;
1.2 albertel 181: $newkey=~s/\Q$pattern\E/$new/;
1.6 www 182: $data{$newkey}=$data{$key};
183: delete $data{$key};
184: }
185: }
186: # transfer hash
187: foreach my $key (keys %data) {
188: my $thiskey=$key;
189: $thiskey=~s/^$origcrsid/$newcrsid/;
190: $newdata{$thiskey}=$data{$key};
191: # date_mode empty or "preserve": transfer dates one-to-one
192: # date_mode "shift": shift dates by date_shift days
193: # date_mode other: do not transfer dates
194: if (($date_mode) && ($date_mode ne 'preserve')) {
195: if ($data{$key.'.type'}=~/^date_(start|end)$/) {
196: if ($date_mode eq 'shift') {
197: $newdata{$thiskey}=$newdata{$thiskey}+$delta;
198: } else {
199: delete($newdata{$thiskey});
200: delete($newdata{$thiskey.'.type'});
201: }
202: }
1.1 albertel 203: }
204: }
205: return &Apache::lonnet::put
206: ('resourcedata',\%newdata,$newcrsdata{'domain'},$newcrsdata{'num'});
207: }
208:
209: # ========================================================== Copy all userfiles
210:
211: sub copyuserfiles {
212: my ($origcrsid,$newcrsid)=@_;
213: foreach (&crsdirlist($origcrsid,'userfiles')) {
214: if ($_ !~m|^scantron_|) {
215: ©file($origcrsid,$newcrsid,$_);
216: }
217: }
218: }
219: # ========================================================== Copy all userfiles
220:
221: sub copydbfiles {
222: my ($origcrsid,$newcrsid)=@_;
223:
224: my ($origcrs_discussion) = ($origcrsid=~m|^/(.*)|);
225: $origcrs_discussion=~s|/|_|g;
226: foreach (&crsdirlist($origcrsid)) {
227: if ($_=~/\.db$/) {
228: unless
229: ($_=~/^(nohist\_|discussiontimes|classlist|versionupdate|resourcedata|\Q$origcrs_discussion\E|slots|slot_reservations|gradingqueue|reviewqueue|CODEs|groupmembership)/) {
230: ©db($origcrsid,$newcrsid,$_);
231: }
232: }
233: }
234: }
235:
236: # ======================================================= Copy all course files
237:
238: sub copycoursefiles {
1.6 www 239: my ($origcrsid,$newcrsid,$date_mode,$date_shift)=@_;
1.1 albertel 240: ©userfiles($origcrsid,$newcrsid);
241: ©dbfiles($origcrsid,$newcrsid);
1.6 www 242: ©resourcedb($origcrsid,$newcrsid,$date_mode,$date_shift);
1.1 albertel 243: }
244:
1.7.12.1! raeburn 245: sub copyroster {
! 246: my ($origcrsid,$newcrsid,$accessstart,$accessend) = @_;
! 247: my %origcrsdata=&Apache::lonnet::coursedescription($origcrsid);
! 248: my $newcrsiddata=&Apache::lonnet::coursedescription($newcrsid);
! 249:
! 250: my $classlist =
! 251: &Apache::loncoursedata::get_classlist($origcrsdata{'domain'},$origcrsdata{'num'});
! 252: my %origdate = &Apache::lonnet::get('environment',
! 253: ['default_enrollment_end_date'],
! 254: $origcrsdata{'domain'},$origcrsdata{'num'});
! 255:
! 256: my $enddate = $origdate{'default_enrollment_end_date'};
! 257:
! 258: my $sec_idx = &Apache::loncoursedata::CL_SECTION();
! 259: my $status_idx = &Apache::loncoursedata::CL_STATUS();
! 260: my $end_idx = &Apache::loncoursedata::CL_END();
! 261: my $start_idx = &Apache::loncoursedata::CL_START();
! 262:
! 263: my (%newstudents,%rolesadded,$numadded);
! 264: my $numadded = 0;
! 265: my $classlist = &Apache::loncoursedata::get_classlist();
! 266: if (ref($classlist) eq 'HASH') {
! 267: foreach my $student (sort(keys(%{$classlist}))) {
! 268: my ($sname,$sdom) = split(/:/,$student);
! 269: next if ($classlist->{$student}->[$end_idx] eq '-1'
! 270: || ($classlist->{$student}->[$start_idx] eq '-1'));
! 271: if (($classlist->{$student}->[$status_idx] eq 'Active') ||
! 272: ($classlist->{$student}->[$end_idx] >= $enddate)) {
! 273: if (ref($classlist->{$student}) eq 'ARRAY') {
! 274: my @info = @{$classlist->{$student}};
! 275: $info[$end_idx] = $accessend;
! 276: $info[$start_idx] = $accessstart;
! 277: $newstudents{$student}{'info'} = join(':',@info);
! 278: $newstudents{$student}{'section'} =
! 279: $classlist->{$student}->[$sec_idx];
! 280: }
! 281: }
! 282: }
! 283: }
! 284: if (keys(%newstudents)) {
! 285: my $uurl='/'.$newcrsid;
! 286: $uurl=~s/\_/\//g;
! 287: foreach my $student (sort(keys(%newstudents))) {
! 288: my $surl = $uurl;
! 289: if ($newstudents{$student}{'section'}) {
! 290: $surl.='/'.$newstudents{$student}{'section'};
! 291: }
! 292: if (&assignrole($sdom,$sname,$uurl,'st',$accessend,$accessstart,undef,undef,'requestcourses') eq 'ok') {
! 293: $rolesadded{$student} = $newstudents{$student};
! 294: $numadded ++ ;
! 295: }
! 296: }
! 297: }
! 298: my $clisterror;
! 299: if (keys(%rolesadded) > 0) {
! 300: my $reply=cput('classlist',\%rolesadded,$newcrsdata{'domain'},$newcrsdata{'num'});
! 301: unless (($reply eq 'ok') || ($reply eq 'delayed')) {
! 302: $clisterror = 'error: '.$reply;
! 303: }
! 304: }
! 305: return ($numadded,$clisterror);
! 306: }
! 307:
1.1 albertel 308: 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