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: 	    &copyfile($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: 		 &copydb($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:     &copyuserfiles($origcrsid,$newcrsid);
                    243:     &copydbfiles($origcrsid,$newcrsid);
1.6       www       244:     &copyresourcedb($origcrsid,$newcrsid,$date_mode,$date_shift);
1.1       albertel  245: }
                    246: 
                    247: 1;

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