--- loncom/lonnet/perl/lonnet.pm 2015/05/21 23:10:57 1.1286 +++ loncom/lonnet/perl/lonnet.pm 2015/05/21 23:40:25 1.1287 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.1286 2015/05/21 23:10:57 raeburn Exp $ +# $Id: lonnet.pm,v 1.1287 2015/05/21 23:40:25 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -4280,7 +4280,7 @@ sub courseiddump { $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok, $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone, $cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner, - $hasuniquecode)=@_; + $hasuniquecode,$reqcrsdom,$reqinstcode)=@_; my $as_hash = 1; my %returnhash; if (!$domfilter) { $domfilter=''; } @@ -4303,7 +4303,8 @@ sub courseiddump { &escape($catfilter), $showhidden, $caller, &escape($cloner), &escape($cc_clone), $cloneonly, &escape($createdbefore), &escape($createdafter), - &escape($creationcontext), $domcloner, $hasuniquecode))); + &escape($creationcontext),$domcloner,$hasuniquecode, + $reqcrsdom,&escape($reqinstcode)))); } else { $rep = &reply('courseiddump:'.&host_domain($tryserver).':'. $sincefilter.':'.&escape($descfilter).':'. @@ -4314,8 +4315,8 @@ sub courseiddump { $showhidden.':'.$caller.':'.&escape($cloner).':'. &escape($cc_clone).':'.$cloneonly.':'. &escape($createdbefore).':'.&escape($createdafter).':'. - &escape($creationcontext).':'.$domcloner.':'.$hasuniquecode, - $tryserver); + &escape($creationcontext).':'.$domcloner.':'.$hasuniquecode. + ':'.$reqcrsdom.':'.&escape($reqinstcode),$tryserver); } my @pairs=split(/\&/,$rep); @@ -8100,6 +8101,80 @@ sub auto_crsreq_update { return \%crsreqresponse; } +sub check_instcode_cloning { + my ($codedefaults,$code_order,$cloner,$clonefromcode,$clonetocode) = @_; + unless ((ref($codedefaults) eq 'HASH') && (ref($code_order) eq 'ARRAY')) { + return; + } + my $canclone; + if (@{$code_order} > 0) { + my $instcoderegexp ='^'; + my @clonecodes = split(/\&/,$cloner); + foreach my $item (@{$code_order}) { + if (grep(/^\Q$item\E=/,@clonecodes)) { + foreach my $pair (@clonecodes) { + my ($key,$val) = split(/\=/,$pair,2); + $val = &unescape($val); + if ($key eq $item) { + $instcoderegexp .= '('.$val.')'; + last; + } + } + } else { + $instcoderegexp .= $codedefaults->{$item}; + } + } + $instcoderegexp .= '$'; + my (@from,@to); + eval { + (@from) = ($clonefromcode =~ /$instcoderegexp/); + (@to) = ($clonetocode =~ /$instcoderegexp/); + }; + if ((@from > 0) && (@to > 0)) { + my @diffs = &Apache::loncommon::compare_arrays(\@from,\@to); + if (!@diffs) { + $canclone = 1; + } + } + } + return $canclone; +} + +sub default_instcode_cloning { + my ($clonedom,$domdefclone,$clonefromcode,$clonetocode,$codedefaultsref,$codeorderref) = @_; + my (%codedefaults,@code_order,$canclone); + if ((ref($codedefaultsref) eq 'HASH') && (ref($codeorderref) eq 'ARRAY')) { + %codedefaults = %{$codedefaultsref}; + @code_order = @{$codeorderref}; + } elsif ($clonedom) { + &auto_instcode_defaults($clonedom,\%codedefaults,\@code_order); + } + if (($domdefclone) && (@code_order)) { + my @clonecodes = split(/\+/,$domdefclone); + my $instcoderegexp ='^'; + foreach my $item (@code_order) { + if (grep(/^\Q$item\E$/,@clonecodes)) { + $instcoderegexp .= '('.$codedefaults{$item}.')'; + } else { + $instcoderegexp .= $codedefaults{$item}; + } + } + $instcoderegexp .= '$'; + my (@from,@to); + eval { + (@from) = ($clonefromcode =~ /$instcoderegexp/); + (@to) = ($clonetocode =~ /$instcoderegexp/); + }; + if ((@from > 0) && (@to > 0)) { + my @diffs = &Apache::loncommon::compare_arrays(\@from,\@to); + if (!@diffs) { + $canclone = 1; + } + } + } + return $canclone; +} + # ------------------------------------------------------- Course Group routines sub get_coursegroups {