+ $starting
+
+
+ENDPROGBAR
+ &r_print($r,$content.&LCprogressbar_script($LCcurrentid));
+}
+
+sub LCprogressbarUpdate {
+ my ($r,$val,$text)=@_;
+ unless ($val) {
+ if ($LClastpercent) {
+ $val=$LClastpercent;
+ } else {
+ $val=0;
+ }
+ }
+ if ($val<0) { $val=0; }
+ if ($val>100) { $val=0; }
+ $LClastpercent=$val;
+ unless ($text) { $text=$val.'%'; }
+ $text=&js_ready($text);
+ &r_print($r,<
+END
+}
+
+sub end_scrollbox {
+ return ' |
'.&mt($msg).'
'. &Apache::loncommon::end_page(); if (ref($r)) { $r->print($page); @@ -6929,31 +7954,48 @@ sub simple_error_page { { my @row_count; + + sub start_data_table_count { + unshift(@row_count, 0); + return; + } + + sub end_data_table_count { + shift(@row_count); + return; + } + sub start_data_table { - my ($add_class) = @_; + my ($add_class,$id) = @_; my $css_class = (join(' ','LC_data_table',$add_class)); - unshift(@row_count,0); - return '&"').'" onclick="javascript:setSearch(\'1\','.$caller.');" />
'; } else { @@ -7832,7 +8898,7 @@ function setSearch(createnew,callingForm } } for (var i=0; i'.&mt("$text{$check} with the following format(s) may only be used for verified users at [_1]:",$domdesc).'
- ';
+ $output = '
'. + &mt($text{$check}.' with the following format(s) may [_1]only[_2] be used for verified users at [_3]:', + '','',$domdesc). + '
- ';
foreach my $rule (@{$ruleorder}) {
if (ref($curr_rules) eq 'ARRAY') {
if (grep(/^\Q$rule\E$/,@{$curr_rules})) {
@@ -8155,6 +9224,10 @@ sub get_institutional_codes {
return;
}
+sub get_standard_codeitems {
+ return ('Year','Semester','Department','Number','Section');
+}
+
=pod
=head1 Slot Helpers
@@ -8163,7 +9236,8 @@ sub get_institutional_codes {
=item * sorted_slots()
-Sorts an array of slot names in order of slot start time (earliest first).
+Sorts an array of slot names in order of an optional sort key,
+default sort is by slot start time (earliest first).
Inputs:
@@ -8173,15 +9247,16 @@ slotsarr - Reference to array of unsort
slots - Reference to hash of hash, where outer hash keys are slot names.
+sortkey - Name of key in inner hash to be sorted on (e.g., starttime).
+
=back
Returns:
=over 4
-sorted - An array of slot names sorted by the start time of the slot.
-
-=back
+sorted - An array of slot names sorted by a specified sort key
+ (default sort key is start time of the slot).
=back
@@ -8189,13 +9264,16 @@ sorted - An array of slot names sorted
sub sorted_slots {
- my ($slotsarr,$slots) = @_;
+ my ($slotsarr,$slots,$sortkey) = @_;
+ if ($sortkey eq '') {
+ $sortkey = 'starttime';
+ }
my @sorted;
if ((ref($slotsarr) eq 'ARRAY') && (ref($slots) eq 'HASH')) {
@sorted =
sort {
if (ref($slots->{$a}) && ref($slots->{$b})) {
- return $slots->{$a}{'starttime'} <=> $slots->{$b}{'starttime'}
+ return $slots->{$a}{$sortkey} <=> $slots->{$b}{$sortkey}
}
if (ref($slots->{$a})) { return -1;}
if (ref($slots->{$b})) { return 1;}
@@ -8205,9 +9283,136 @@ sub sorted_slots {
return @sorted;
}
+=pod
+
+=item * get_future_slots()
+
+Inputs:
+
+=over 4
+
+cnum - course number
+
+cdom - course domain
+
+now - current UNIX time
+
+symb - optional symb
+
+=back
+
+Returns:
+
+=over 4
+
+sorted_reservable - ref to array of student_schedulable slots currently
+ reservable, ordered by end date of reservation period.
+
+reservable_now - ref to hash of student_schedulable slots currently
+ reservable.
+
+ Keys in inner hash are:
+ (a) symb: either blank or symb to which slot use is restricted.
+ (b) endreserve: end date of reservation period.
+
+sorted_future - ref to array of student_schedulable slots reservable in
+ the future, ordered by start date of reservation period.
+
+future_reservable - ref to hash of student_schedulable slots reservable
+ in the future.
+
+ Keys in inner hash are:
+ (a) symb: either blank or symb to which slot use is restricted.
+ (b) startreserve: start date of reservation period.
+
+=back
+
+=cut
+
+sub get_future_slots {
+ my ($cnum,$cdom,$now,$symb) = @_;
+ my (%reservable_now,%future_reservable,@sorted_reservable,@sorted_future);
+ my %slots = &Apache::lonnet::get_course_slots($cnum,$cdom);
+ foreach my $slot (keys(%slots)) {
+ next unless($slots{$slot}->{'type'} eq 'schedulable_student');
+ if ($symb) {
+ next if (($slots{$slot}->{'symb'} ne '') &&
+ ($slots{$slot}->{'symb'} ne $symb));
+ }
+ if (($slots{$slot}->{'starttime'} > $now) &&
+ ($slots{$slot}->{'endtime'} > $now)) {
+ if (($slots{$slot}->{'allowedsections'}) || ($slots{$slot}->{'allowedusers'})) {
+ my $userallowed = 0;
+ if ($slots{$slot}->{'allowedsections'}) {
+ my @allowed_sec = split(',',$slots{$slot}->{'allowedsections'});
+ if (!defined($env{'request.role.sec'})
+ && grep(/^No section assigned$/,@allowed_sec)) {
+ $userallowed=1;
+ } else {
+ if (grep(/^\Q$env{'request.role.sec'}\E$/,@allowed_sec)) {
+ $userallowed=1;
+ }
+ }
+ unless ($userallowed) {
+ if (defined($env{'request.course.groups'})) {
+ my @groups = split(/:/,$env{'request.course.groups'});
+ foreach my $group (@groups) {
+ if (grep(/^\Q$group\E$/,@allowed_sec)) {
+ $userallowed=1;
+ last;
+ }
+ }
+ }
+ }
+ }
+ if ($slots{$slot}->{'allowedusers'}) {
+ my @allowed_users = split(',',$slots{$slot}->{'allowedusers'});
+ my $user = $env{'user.name'}.':'.$env{'user.domain'};
+ if (grep(/^\Q$user\E$/,@allowed_users)) {
+ $userallowed = 1;
+ }
+ }
+ next unless($userallowed);
+ }
+ my $startreserve = $slots{$slot}->{'startreserve'};
+ my $endreserve = $slots{$slot}->{'endreserve'};
+ my $symb = $slots{$slot}->{'symb'};
+ if (($startreserve < $now) &&
+ (!$endreserve || $endreserve > $now)) {
+ my $lastres = $endreserve;
+ if (!$lastres) {
+ $lastres = $slots{$slot}->{'starttime'};
+ }
+ $reservable_now{$slot} = {
+ symb => $symb,
+ endreserve => $lastres
+ };
+ } elsif (($startreserve > $now) &&
+ (!$endreserve || $endreserve > $startreserve)) {
+ $future_reservable{$slot} = {
+ symb => $symb,
+ startreserve => $startreserve
+ };
+ }
+ }
+ }
+ my @unsorted_reservable = keys(%reservable_now);
+ if (@unsorted_reservable > 0) {
+ @sorted_reservable =
+ &sorted_slots(\@unsorted_reservable,\%reservable_now,'endreserve');
+ }
+ my @unsorted_future = keys(%future_reservable);
+ if (@unsorted_future > 0) {
+ @sorted_future =
+ &sorted_slots(\@unsorted_future,\%future_reservable,'startreserve');
+ }
+ return (\@sorted_reservable,\%reservable_now,\@sorted_future,\%future_reservable);
+}
=pod
+=back
+
=head1 HTTP Helpers
=over 4
@@ -8346,68 +9551,586 @@ sub get_env_multiple {
sub ask_for_embedded_content {
my ($actionurl,$state,$allfiles,$codebase,$args)=@_;
- my $upload_output = '
-
'.&mt('or').'
'; + } + } + return ($output,$counter,$numpathchg); +} + +sub embedded_file_element { + my ($context,$num,$embed_file,$mapping,$allfiles,$codebase,$type) = @_; + return unless ((ref($mapping) eq 'HASH') && (ref($allfiles) eq 'HASH') && + (ref($codebase) eq 'HASH')); + my $output; + if (($context eq 'upload_embedded') && ($type ne 'delete')) { + $output = ''."\n"; + } + $output .= ''; + unless (($context eq 'upload_embedded') && + ($mapping->{$embed_file} eq $embed_file)) { + $output .=' + '; + } + my $attrib; + if (ref($allfiles->{$mapping->{$embed_file}}) eq 'ARRAY') { + $attrib = &escape(join(':',@{$allfiles->{$mapping->{$embed_file}}})); + } + $output .= + "\n\t\t". + ''; + if (exists($codebase->{$mapping->{$embed_file}})) { + $output .= + "\n\t\t". + ''; + } + return $output; +} - $upload_output.=''.&mt("Invalid characters").''; - +sub get_dependency_details { + my ($currfile,$currsubfile,$embed_file) = @_; + my ($size,$mtime,$showsize,$showmtime); + if ((ref($currfile) eq 'HASH') && (ref($currsubfile))) { + if ($embed_file =~ m{/}) { + my ($path,$fname) = split(/\//,$embed_file); + if (ref($currsubfile->{$path}{$fname}) eq 'ARRAY') { + ($size,$mtime) = @{$currsubfile->{$path}{$fname}}; + } } else { - $upload_output .=' - - '; - my $attrib = join(':',@{$$allfiles{$embed_file}}); - $upload_output .= - "\n\t\t". - ''; - if (exists($$codebase{$embed_file})) { - $upload_output .= - "\n\t\t". - ''; - } - } - $upload_output .= ''.&Apache::loncommon::end_data_table_row(); - $num++; - } - $upload_output .= &Apache::loncommon::end_data_table().'- - - '.&mt('(only files for which a location has been provided will be uploaded)').' - '; - return $upload_output; + if (ref($currfile->{$embed_file}) eq 'ARRAY') { + ($size,$mtime) = @{$currfile->{$embed_file}}; + } + } + $showsize = $size/1024.0; + $showsize = sprintf("%.1f",$showsize); + if ($mtime > 0) { + $showmtime = &Apache::lonlocal::locallocaltime($mtime); + } + } + return ($showsize,$showmtime); +} + +sub ask_embedded_js { + return <<"END"; + + +END } sub upload_embedded { my ($context,$dirpath,$uname,$udom,$dir_root,$url_root,$group,$disk_quota, - $current_disk_usage) = @_; - my $output; + $current_disk_usage,$hiddenstate,$actionurl) = @_; + my (%pathchange,$output,$modifyform,$footer,$returnflag); for (my $i=0; $i<$env{'form.number_embedded_items'}; $i++) { next if (!exists($env{'form.embedded_item_'.$i.'.filename'})); my $orig_uploaded_filename = $env{'form.embedded_item_'.$i.'.filename'}; - - $env{'form.embedded_orig_'.$i} = - &unescape($env{'form.embedded_orig_'.$i}); + foreach my $type ('orig','ref','attrib','codebase') { + if ($env{'form.embedded_'.$type.'_'.$i} ne '') { + $env{'form.embedded_'.$type.'_'.$i} = + &unescape($env{'form.embedded_'.$type.'_'.$i}); + } + } my ($path,$fname) = ($env{'form.embedded_orig_'.$i} =~ m{(.*/)([^/]*)}); # no path, whole string is fname if (!$fname) { $fname = $env{'form.embedded_orig_'.$i} }; - - $path = $env{'form.currentpath'}.$path; $fname = &Apache::lonnet::clean_filename($fname); # See if there is anything left next if ($fname eq ''); @@ -8419,12 +10142,12 @@ sub upload_embedded { if ($group ne '') { $port_path = "groups/$group/$port_path"; } - ($state,$msg) = &check_for_upload($path,$fname,$group,'embedded_item_'.$i, + ($state,$msg) = &check_for_upload($env{'form.currentpath'}.$path, + $fname,$group,'embedded_item_'.$i, $dir_root,$port_path,$disk_quota, $current_disk_usage,$uname,$udom); if ($state eq 'will_exceed_quota' - || $state eq 'file_locked' - || $state eq 'file_exists' ) { + || $state eq 'file_locked') { $output .= $msg; next; } @@ -8438,31 +10161,55 @@ sub upload_embedded { # Check if extension is valid if (($fname =~ /\.(\w+)$/) && (&Apache::loncommon::fileembstyle($1) eq 'hdn')) { - $output .= &mt('Invalid file extension ([_1]) - reserved for LONCAPA use - rename the file with a different extension and re-upload. ',$1); + $output .= &mt('Invalid file extension ([_1]) - reserved for LONCAPA use - rename the file with a different extension and re-upload. ',$1).'
'; next; } elsif (($fname =~ /\.(\w+)$/) && (!defined(&Apache::loncommon::fileembstyle($1)))) { - $output .= &mt('Unrecognized file extension ([_1]) - rename the file with a proper extension and re-upload.',$1); + $output .= &mt('Unrecognized file extension ([_1]) - rename the file with a proper extension and re-upload.',$1).'
'; next; } elsif ($fname=~/\.(\d+)\.(\w+)$/) { - $output .= &mt('File name not allowed - rename the file to remove the number immediately before the file extension([_1]) and re-upload.',$2); + $output .= &mt('Filename not allowed - rename the file to remove the number immediately before the file extension([_1]) and re-upload.',$2).'
'; next; } - $env{'form.embedded_item_'.$i.'.filename'}=$fname; + my $subdir = $path; + $subdir =~ s{/+$}{}; if ($context eq 'portfolio') { - my $result= - &Apache::lonnet::userfileupload('embedded_item_'.$i,'', - $dirpath.$path); + my $result; + if ($state eq 'existingfile') { + $result= + &Apache::lonnet::userfileupload('embedded_item_'.$i,'existingfile', + $dirpath.$env{'form.currentpath'}.$subdir); + } else { + $result= + &Apache::lonnet::userfileupload('embedded_item_'.$i,'', + $dirpath. + $env{'form.currentpath'}.$subdir); + if ($result !~ m|^/uploaded/|) { + $output .= '' + .&mt('An error occurred ([_1]) while trying to upload [_2] for embedded element [_3].' + ,$result,$orig_uploaded_filename,$env{'form.embedded_orig_'.$i}) + .'
'; + next; + } else { + $output .= &mt('Uploaded [_1]',''. + $path.$fname.'').'
'; + } + } + } elsif (($context eq 'coursedoc') || ($context eq 'syllabus')) { + my $result = + &Apache::lonnet::userfileupload('embedded_item_'.$i,$context, + $dirpath.'/'.$subdir); if ($result !~ m|^/uploaded/|) { $output .= '' - .&mt('An error occurred ([_1]) while trying to upload [_2] for embedded element [_3].' + .&mt('An error occurred ([_1]) while trying to upload [_2] for embedded element [_3].' ,$result,$orig_uploaded_filename,$env{'form.embedded_orig_'.$i}) - .'
'; - next; + .'
'; + next; } else { - $output .= '
'.&mt('Uploaded [_1]',''. - $path.$fname.'').'
'; + $output .= &mt('Uploaded [_1]',''. + $path.$fname.'').''; + &Apache::lonnet::make_public_indefinitely($result); } } else { # Save the file @@ -8470,12 +10217,12 @@ sub upload_embedded { my $fullpath = $dir_root.$dirpath.'/'.$path; my $dest = $fullpath.$fname; my $url = $url_root.$dirpath.'/'.$path.$fname; - my @parts=split(/\//,$fullpath); + my @parts=split(/\//,"$dirpath/$path"); my $count; my $filepath = $dir_root; - for ($count=4;$count<=$#parts;$count++) { - $filepath .= "/$parts[$count]"; - if ((-e $filepath)!=1) { + foreach my $subdir (@parts) { + $filepath .= "/$subdir"; + if (!-e $filepath) { mkdir($filepath,0770); } } @@ -8483,30 +10230,294 @@ sub upload_embedded { if (!open($fh,'>'.$dest)) { &Apache::lonnet::logthis('Failed to create '.$dest); $output .= ''. - &mt('An error occurred while trying to upload [_1] for embedded element [_2].',$orig_uploaded_filename,$env{'form.embedded_orig_'.$i}). + &mt('An error occurred while trying to upload [_1] for embedded element [_2].', + $orig_uploaded_filename,$env{'form.embedded_orig_'.$i}). '
'; } else { if (!print $fh $env{'form.embedded_item_'.$i}) { &Apache::lonnet::logthis('Failed to write to '.$dest); $output .= ''. - &mt('An error occurred while writing the file [_1] for embedded element [_2].',$orig_uploaded_filename,$env{'form.embedded_orig_'.$i}). + &mt('An error occurred while writing the file [_1] for embedded element [_2].', + $orig_uploaded_filename,$env{'form.embedded_orig_'.$i}). '
'; } else { - if ($context eq 'testbank') { - $output .= &mt('Embedded file uploaded successfully:'). - ' '. - $orig_uploaded_filename.'
'; - } else { - $output .= ''. - &mt('View embedded file: [_1]',''. - $orig_uploaded_filename.'').'
'; + $output .= &mt('Uploaded [_1]',''. + $url.'').'
'; + unless ($context eq 'testbank') { + $footer .= &mt('View embedded file: [_1]', + ''.$fname.'').'
'; } } close($fh); } } + if ($env{'form.embedded_ref_'.$i}) { + $pathchange{$i} = 1; + } + } + if ($output) { + $output = '
'.$output.'
'; + } + $output .= &modify_html_form('upload_embedded',$actionurl,$hiddenstate,\%pathchange); + $returnflag = 'ok'; + my $numpathchgs = scalar(keys(%pathchange)); + if ($numpathchgs > 0) { + if ($context eq 'portfolio') { + $output .= ''.&mt('or').'
'; + } elsif ($context eq 'testbank') { + $output .= ''.&mt('Or [_1]continue[_2] the testbank import without modifying the reference(s).', + '','').'
'; + $returnflag = 'modify_orightml'; + } + } + return ($output.$footer,$returnflag,$numpathchgs); +} + +sub modify_html_form { + my ($context,$actionurl,$hiddenstate,$pathchange,$pathchgtable) = @_; + my $end = 0; + my $modifyform; + if ($context eq 'upload_embedded') { + return unless (ref($pathchange) eq 'HASH'); + if ($env{'form.number_embedded_items'}) { + $end += $env{'form.number_embedded_items'}; + } + if ($env{'form.number_pathchange_items'}) { + $end += $env{'form.number_pathchange_items'}; + } + if ($end) { + for (my $i=0; $i<$end; $i++) { + if ($i < $env{'form.number_embedded_items'}) { + next unless($pathchange->{$i}); + } + $modifyform .= + &start_data_table_row(). + ''.&mt('Changes in content of HTML file required').'
'."\n". + ''.&mt('Changes need to be made to the reference(s) used for one or more of the dependencies, if your HTML file is to work correctly:').'
- '."\n".
+ '
- '.&mt('For consistency between the reference(s) and the location of the corresponding stored file within LON-CAPA.').' '."\n". + '
- '.&mt('To change absolute paths to relative paths, or replace directory traversal via "../" within the original reference.').' '."\n". + '
'. + &mt('LON-CAPA can make the required changes to your HTML file.').'
'."\n". + ''."\n"; + } + return; +} + +sub modify_html_refs { + my ($context,$dirpath,$uname,$udom,$dir_root,$url) = @_; + my $container; + if ($context eq 'portfolio') { + $container = $env{'form.container'}; + } elsif ($context eq 'coursedoc') { + $container = $env{'form.primaryurl'}; + } elsif ($context eq 'manage_dependencies') { + (undef,undef,$container) = &Apache::lonnet::decode_symb($env{'form.symb'}); + $container = "/$container"; + } elsif ($context eq 'syllabus') { + $container = $url; + } else { + $container = $Apache::lonnet::perlvar{'lonDocRoot'}.$env{'form.filename'}; + } + my (%allfiles,%codebase,$output,$content); + my @changes = &get_env_multiple('form.namechange'); + unless (@changes > 0) { + if (wantarray) { + return ('',0,0); + } else { + return; + } + } + if (($context eq 'portfolio') || ($context eq 'coursedoc') || + ($context eq 'manage_dependencies') || ($context eq 'syllabus')) { + unless ($container =~ m{^/uploaded/\Q$udom\E/\Q$uname\E/}) { + if (wantarray) { + return ('',0,0); + } else { + return; + } + } + $content = &Apache::lonnet::getfile($container); + if ($content eq '-1') { + if (wantarray) { + return ('',0,0); + } else { + return; + } + } + } else { + unless ($container =~ /^\Q$dir_root\E/) { + if (wantarray) { + return ('',0,0); + } else { + return; + } + } + if (open(my $fh,"<$container")) { + $content = join('', <$fh>); + close($fh); + } else { + if (wantarray) { + return ('',0,0); + } else { + return; + } + } + } + my ($count,$codebasecount) = (0,0); + my $mm = new File::MMagic; + my $mime_type = $mm->checktype_contents($content); + if ($mime_type eq 'text/html') { + my $parse_result = + &Apache::lonnet::extract_embedded_items($container,\%allfiles, + \%codebase,\$content); + if ($parse_result eq 'ok') { + foreach my $i (@changes) { + my $orig = &unescape($env{'form.embedded_orig_'.$i}); + my $ref = &unescape($env{'form.embedded_ref_'.$i}); + if ($allfiles{$ref}) { + my $newname = $orig; + my ($attrib_regexp,$codebase); + $attrib_regexp = &unescape($env{'form.embedded_attrib_'.$i}); + if ($attrib_regexp =~ /:/) { + $attrib_regexp =~ s/\:/|/g; + } + if ($content =~ m{($attrib_regexp\s*=\s*['"]?)\Q$ref\E(['"]?)}) { + my $numchg = ($content =~ s{($attrib_regexp\s*=\s*['"]?)\Q$ref\E(['"]?)}{$1$newname$2}gi); + $count += $numchg; + $allfiles{$newname} = $allfiles{$ref}; + } + if ($env{'form.embedded_codebase_'.$i} ne '') { + $codebase = &unescape($env{'form.embedded_codebase_'.$i}); + my $numchg = ($content =~ s/(codebase\s*=\s*["']?)\Q$codebase\E(["']?)/$1.$2/i); #' stupid emacs + $codebasecount ++; + } + } + } + my $skiprewrites; + if ($count || $codebasecount) { + my $saveresult; + if (($context eq 'portfolio') || ($context eq 'coursedoc') || + ($context eq 'manage_dependencies') || ($context eq 'syllabus')) { + my $url = &Apache::lonnet::store_edited_file($container,$content,$udom,$uname,\$saveresult); + if ($url eq $container) { + my ($fname) = ($container =~ m{/([^/]+)$}); + $output = ''.&mt('Updated [quant,_1,reference] in [_2].', + $count,''. + $fname.'').'
'; + } else { + $output = ''. + &mt('Error: update failed for: [_1].', + ''. + $container.'').'
'; + } + if ($context eq 'syllabus') { + unless ($saveresult eq 'ok') { + $skiprewrites = 1; + } + } + } else { + if (open(my $fh,">$container")) { + print $fh $content; + close($fh); + $output = ''.&mt('Updated [quant,_1,reference] in [_2].', + $count,''. + $container.'').'
'; + } else { + $output = ''. + &mt('Error: could not update [_1].', + ''. + $container.'').'
'; + } + } + } + if (($context eq 'syllabus') && (!$skiprewrites)) { + my ($actionurl,$state); + $actionurl = "/public/$udom/$uname/syllabus"; + my ($ignore,$num,$numpathchanges,$existing,$mapping) = + &ask_for_embedded_content($actionurl,$state,\%allfiles, + \%codebase, + {'context' => 'rewrites', + 'ignore_remote_references' => 1,}); + if (ref($mapping) eq 'HASH') { + my $rewrites = 0; + foreach my $key (keys(%{$mapping})) { + next if ($key =~ m{^https?://}); + my $ref = $mapping->{$key}; + my $newname = "/uploaded/$udom/$uname/portfolio/syllabus/$key"; + my $attrib; + if (ref($allfiles{$mapping->{$key}}) eq 'ARRAY') { + $attrib = join('|',@{$allfiles{$mapping->{$key}}}); + } + if ($content =~ m{($attrib\s*=\s*['"]?)\Q$ref\E(['"]?)}) { + my $numchg = ($content =~ s{($attrib\s*=\s*['"]?)\Q$ref\E(['"]?)}{$1$newname$2}gi); + $rewrites += $numchg; + } + } + if ($rewrites) { + my $saveresult; + my $url = &Apache::lonnet::store_edited_file($container,$content,$udom,$uname,\$saveresult); + if ($url eq $container) { + my ($fname) = ($container =~ m{/([^/]+)$}); + $output .= ''.&mt('Rewrote [quant,_1,link] as [quant,_1,absolute link] in [_2].', + $count,''. + $fname.'').'
'; + } else { + $output .= ''. + &mt('Error: could not update links in [_1].', + ''. + $container.'').'
'; + + } + } + } + } + } else { + &logthis('Failed to parse '.$container. + ' to modify references: '.$parse_result); + } + } + if (wantarray) { + return ($output,$count,$codebasecount); + } else { + return $output; } - return $output; } sub check_for_existing { @@ -8528,22 +10539,73 @@ sub check_for_existing { sub check_for_upload { my ($path,$fname,$group,$element,$portfolio_root,$port_path, $disk_quota,$current_disk_usage,$uname,$udom) = @_; - my $filesize = (length($env{'form.'.$element})) / 1000; #express in k (1024?) + my $filesize = length($env{'form.'.$element}); + if (!$filesize) { + my $msg = ''. + &mt('Unable to upload [_1]. (size = [_2] bytes)', + ''.$fname.'', + $filesize).''. + &mt('Either the file you attempted to upload was empty, or your web browser was unable to read its contents.').'
'. + ''; + return ('zero_bytes',$msg); + } + $filesize = $filesize/1000; #express in k (1024?) my $getpropath = 1; - my @dir_list = &Apache::lonnet::dirlist($portfolio_root.$path,$udom,$uname, - $getpropath); + my ($dirlistref,$listerror) = + &Apache::lonnet::dirlist($portfolio_root.$path,$udom,$uname,$getpropath); my $found_file = 0; my $locked_file = 0; - foreach my $line (@dir_list) { - my ($file_name)=split(/\&/,$line,2); - if ($file_name eq $fname){ - $file_name = $path.$file_name; - if ($group ne '') { - $file_name = $group.$file_name; - } - $found_file = 1; - if (&Apache::lonnet::is_locked($file_name,$udom,$uname) eq 'true') { - $locked_file = 1; + my @lockers; + my $navmap; + if ($env{'request.course.id'}) { + $navmap = Apache::lonnavmaps::navmap->new(); + } + if (ref($dirlistref) eq 'ARRAY') { + foreach my $line (@{$dirlistref}) { + my ($file_name,$rest)=split(/\&/,$line,2); + if ($file_name eq $fname){ + $file_name = $path.$file_name; + if ($group ne '') { + $file_name = $group.$file_name; + } + $found_file = 1; + if (&Apache::lonnet::is_locked($file_name,$udom,$uname,\@lockers) eq 'true') { + foreach my $lock (@lockers) { + if (ref($lock) eq 'ARRAY') { + my ($symb,$crsid) = @{$lock}; + if ($crsid eq $env{'request.course.id'}) { + if (ref($navmap)) { + my $res = $navmap->getBySymb($symb); + foreach my $part (@{$res->parts()}) { + my ($slot_status,$slot_time,$slot_name)=$res->check_for_slot($part); + unless (($slot_status == $res->RESERVED) || + ($slot_status == $res->RESERVED_LOCATION)) { + $locked_file = 1; + } + } + } else { + $locked_file = 1; + } + } else { + $locked_file = 1; + } + } + } + } else { + my @info = split(/\&/,$rest); + my $currsize = $info[6]/1000; + if ($currsize < $filesize) { + my $extra = $filesize - $currsize; + if (($current_disk_usage + $extra) > $disk_quota) { + my $msg = ''. + &mt('Unable to upload [_1]. (size = [_2] kilobytes). Disk quota will be exceeded if existing (smaller) file with same name (size = [_3] kilobytes) is replaced.', + ''.$fname.'',$filesize,$currsize).''. + '
'.&mt('Disk quota is [_1] kilobytes. Your current disk usage is [_2] kilobytes.', + $disk_quota,$current_disk_usage); + return ('will_exceed_quota',$msg); + } + } + } } } } @@ -8561,15 +10623,1328 @@ sub check_for_upload { return ('file_locked',$msg); } else { my $msg = ''; - $msg .= &mt('Unable to upload [_1]. A file by that name was found in [_2].',''.$fname.'',$port_path.$env{'form.currentpath'}); + $msg .= &mt(' A file by that name: [_1] was found in [_2].',''.$fname.'',$port_path.$env{'form.currentpath'}); $msg .= ''; - $msg .= '
'; - $msg .= &mt('To upload, rename or delete existing [_1] in [_2].',''.$fname.'', $port_path.$env{'form.currentpath'}); - return ('file_exists',$msg); + return ('existingfile',$msg); } } } +sub check_for_traversal { + my ($path,$url,$toplevel) = @_; + my @parts=split(/\//,$path); + my $cleanpath; + my $fullpath = $url; + for (my $i=0;$i<@parts;$i++) { + next if ($parts[$i] eq '.'); + if ($parts[$i] eq '..') { + $fullpath =~ s{([^/]+/)$}{}; + } else { + $fullpath .= $parts[$i].'/'; + } + } + if ($fullpath =~ /^\Q$url\E(.*)$/) { + $cleanpath = $1; + } elsif ($fullpath =~ /^\Q$toplevel\E(.*)$/) { + my $curr_toprel = $1; + my @parts = split(/\//,$curr_toprel); + my ($url_toprel) = ($url =~ /^\Q$toplevel\E(.*)$/); + my @urlparts = split(/\//,$url_toprel); + my $doubledots; + my $startdiff = -1; + for (my $i=0; $i<@urlparts; $i++) { + if ($startdiff == -1) { + unless ($urlparts[$i] eq $parts[$i]) { + $startdiff = $i; + $doubledots .= '../'; + } + } else { + $doubledots .= '../'; + } + } + if ($startdiff > -1) { + $cleanpath = $doubledots; + for (my $i=$startdiff; $i<@parts; $i++) { + $cleanpath .= $parts[$i].'/'; + } + } + } + $cleanpath =~ s{(/)$}{}; + return $cleanpath; +} + +sub is_archive_file { + my ($mimetype) = @_; + if (($mimetype eq 'application/octet-stream') || + ($mimetype eq 'application/x-stuffit') || + ($mimetype =~ m{^application/(x\-)?(compressed|tar|zip|tgz|gz|gtar|gzip|gunzip|bz|bz2|bzip2)})) { + return 1; + } + return; +} + +sub decompress_form { + my ($mimetype,$archiveurl,$action,$noextract,$hiddenelements,$dirlist) = @_; + my %lt = &Apache::lonlocal::texthash ( + this => 'This file is an archive file.', + camt => 'This file is a Camtasia archive file.', + itsc => 'Its contents are as follows:', + youm => 'You may wish to extract its contents.', + extr => 'Extract contents', + auto => 'LON-CAPA can process the files automatically, or you can decide how each should be handled.', + proa => 'Process automatically?', + yes => 'Yes', + no => 'No', + fold => 'Title for folder containing movie', + movi => 'Title for page containing embedded movie', + ); + my $fileloc = &Apache::lonnet::filelocation(undef,$archiveurl); + my ($is_camtasia,$topdir,%toplevel,@paths); + my $info = &list_archive_contents($fileloc,\@paths); + if (@paths) { + foreach my $path (@paths) { + $path =~ s{^/}{}; + if ($path =~ m{^([^/]+)/$}) { + $topdir = $1; + } + if ($path =~ m{^([^/]+)/}) { + $toplevel{$1} = $path; + } else { + $toplevel{$path} = $path; + } + } + } + if ($mimetype =~ m{^application/(x\-)?(compressed|zip)}) { + my @camtasia = ("$topdir/","$topdir/index.html", + "$topdir/media/", + "$topdir/media/$topdir.mp4", + "$topdir/media/FirstFrame.png", + "$topdir/media/player.swf", + "$topdir/media/swfobject.js", + "$topdir/media/expressInstall.swf"); + my @diffs = &compare_arrays(\@paths,\@camtasia); + if (@diffs == 0) { + $is_camtasia = 1; + } + } + my $output; + if ($is_camtasia) { + $output = <<"ENDCAM"; + +
$lt{'camt'}
+ENDCAM + } else { + $output = ''.$lt{'this'}; + if ($info eq '') { + $output .= ' '.$lt{'youm'}.'
'."\n"; + } else { + $output .= ' '.$lt{'itsc'}.''."\n". + ''.$info.'
'.&mt('Filename should end with one of: [_1].', + '.zip, .tar, .bz2, .gz, .tar.gz, .tar.bz2, .tgz'); + } else { + my $docuhome = &Apache::lonnet::homeserver($docuname,$docudom); + if ($docuhome eq 'no_host') { + $error = &mt('Could not determine home server for course.'); + } else { + my @ids=&Apache::lonnet::current_machine_ids(); + my $currdir = "$dir_root/$destination"; + if (grep(/^\Q$docuhome\E$/,@ids)) { + $dir = &LONCAPA::propath($docudom,$docuname). + "$dir_root/$destination"; + } else { + $dir = $Apache::lonnet::perlvar{'lonDocRoot'}. + "$dir_root/$docudom/$docuname/$destination"; + unless (&Apache::lonnet::repcopy_userfile("$dir/$file") eq 'ok') { + $error = &mt('Archive file not found.'); + } + } + my (@to_overwrite,@to_skip); + if ($env{'form.archive_overwrite_total'} > 0) { + my $total = $env{'form.archive_overwrite_total'}; + for (my $i=0; $i<$total; $i++) { + if ($env{'form.archive_overwrite_'.$i} == 1) { + push(@to_overwrite,$env{'form.archive_overwrite_name_'.$i}); + } elsif ($env{'form.archive_overwrite_'.$i} == 0) { + push(@to_skip,$env{'form.archive_overwrite_name_'.$i}); + } + } + } + my $numskip = scalar(@to_skip); + if (($numskip > 0) && + ($numskip == $env{'form.archive_itemcount'})) { + $warning = &mt('All items in the archive file already exist, and no overwriting of existing files has been requested.'); + } elsif ($dir eq '') { + $error = &mt('Directory containing archive file unavailable.'); + } elsif (!$error) { + my ($decompressed,$display); + if ($numskip > 0) { + my $tempdir = time.'_'.$$.int(rand(10000)); + mkdir("$dir/$tempdir",0755); + system("mv $dir/$file $dir/$tempdir/$file"); + ($decompressed,$display) = + &decompress_uploaded_file($file,"$dir/$tempdir"); + foreach my $item (@to_skip) { + if (($item ne '') && ($item !~ /\.\./)) { + if (-f "$dir/$tempdir/$item") { + unlink("$dir/$tempdir/$item"); + } elsif (-d "$dir/$tempdir/$item") { + system("rm -rf $dir/$tempdir/$item"); + } + } + } + system("mv $dir/$tempdir/* $dir"); + rmdir("$dir/$tempdir"); + } else { + ($decompressed,$display) = + &decompress_uploaded_file($file,$dir); + } + if ($decompressed eq 'ok') { + $output = '
'. + &mt('Files extracted successfully from archive.'). + '
'."\n"; + my ($warning,$result,@contents); + my ($newdirlistref,$newlisterror) = + &Apache::lonnet::dirlist($currdir,$docudom, + $docuname,1); + my (%is_dir,%changes,@newitems); + my $dirptr = 16384; + if (ref($newdirlistref) eq 'ARRAY') { + foreach my $dir_line (@{$newdirlistref}) { + my ($item,undef,undef,$testdir)=split(/\&/,$dir_line,5); + unless (($item =~ /^\.+$/) || ($item eq $file) || + ((@to_skip > 0) && (grep(/^\Q$item\E$/,@to_skip)))) { + push(@newitems,$item); + if ($dirptr&$testdir) { + $is_dir{$item} = 1; + } + $changes{$item} = 1; + } + } + } + if (keys(%changes) > 0) { + foreach my $item (sort(@newitems)) { + if ($changes{$item}) { + push(@contents,$item); + } + } + } + if (@contents > 0) { + my $wantform; + unless ($env{'form.autoextract_camtasia'}) { + $wantform = 1; + } + my (%children,%parent,%dirorder,%titles); + my ($count,$datatable) = &get_extracted($docudom,$docuname, + $currdir,\%is_dir, + \%children,\%parent, + \@contents,\%dirorder, + \%titles,$wantform); + if ($datatable ne '') { + $output .= &archive_options_form('decompressed',$datatable, + $count,$hiddenelem); + my $startcount = 6; + $output .= &archive_javascript($startcount,$count, + \%titles,\%children); + } + if ($env{'form.autoextract_camtasia'}) { + my %displayed; + my $total = 1; + $env{'form.archive_directory'} = []; + foreach my $i (sort { $a <=> $b } keys(%dirorder)) { + my $path = join('/',map { $titles{$_}; } @{$dirorder{$i}}); + $path =~ s{/$}{}; + my $item; + if ($path ne '') { + $item = "$path/$titles{$i}"; + } else { + $item = $titles{$i}; + } + $env{'form.archive_content_'.$i} = "$dir_root/$destination/$item"; + if ($item eq $contents[0]) { + push(@{$env{'form.archive_directory'}},$i); + $env{'form.archive_'.$i} = 'display'; + $env{'form.archive_title_'.$i} = $env{'form.camtasia_foldername'}; + $displayed{'folder'} = $i; + } elsif ($item eq "$contents[0]/index.html") { + $env{'form.archive_'.$i} = 'display'; + $env{'form.archive_title_'.$i} = $env{'form.camtasia_moviename'}; + $displayed{'web'} = $i; + } else { + if ($item eq "$contents[0]/media") { + push(@{$env{'form.archive_directory'}},$i); + } + $env{'form.archive_'.$i} = 'dependency'; + } + $total ++; + } + for (my $i=1; $i<$total; $i++) { + next if ($i == $displayed{'web'}); + next if ($i == $displayed{'folder'}); + $env{'form.archive_dependent_on_'.$i} = $displayed{'web'}; + } + $env{'form.phase'} = 'decompress_cleanup'; + $env{'form.archivedelete'} = 1; + $env{'form.archive_count'} = $total-1; + $output .= + &process_extracted_files('coursedocs',$docudom, + $docuname,$destination, + $dir_root,$hiddenelem); + } + } else { + $warning = &mt('No new items extracted from archive file.'); + } + } else { + $output = $display; + $error = &mt('An error occurred during extraction from the archive file.'); + } + } + } + } + if ($error) { + $output .= ''.&mt('Not extracted.').'
'.
+ $error.'
'.$warning.'
'."\n"; + } + return $output; +} + +sub get_extracted { + my ($docudom,$docuname,$currdir,$is_dir,$children,$parent,$contents,$dirorder, + $titles,$wantform) = @_; + my $count = 0; + my $depth = 0; + my $datatable; + my @hierarchy; + return unless ((ref($is_dir) eq 'HASH') && (ref($children) eq 'HASH') && + (ref($parent) eq 'HASH') && (ref($contents) eq 'ARRAY') && + (ref($dirorder) eq 'HASH') && (ref($titles) eq 'HASH')); + foreach my $item (@{$contents}) { + $count ++; + @{$dirorder->{$count}} = @hierarchy; + $titles->{$count} = $item; + &archive_hierarchy($depth,$count,$parent,$children); + if ($wantform) { + $datatable .= &archive_row($is_dir->{$item},$item, + $currdir,$depth,$count); + } + if ($is_dir->{$item}) { + $depth ++; + push(@hierarchy,$count); + $parent->{$depth} = $count; + $datatable .= + &recurse_extracted_archive("$currdir/$item",$docudom,$docuname, + \$depth,\$count,\@hierarchy,$dirorder, + $children,$parent,$titles,$wantform); + $depth --; + pop(@hierarchy); + } + } + return ($count,$datatable); +} + +sub recurse_extracted_archive { + my ($currdir,$docudom,$docuname,$depth,$count,$hierarchy,$dirorder, + $children,$parent,$titles,$wantform) = @_; + my $result=''; + unless ((ref($depth)) && (ref($count)) && (ref($hierarchy) eq 'ARRAY') && + (ref($children) eq 'HASH') && (ref($parent) eq 'HASH') && + (ref($dirorder) eq 'HASH')) { + return $result; + } + my $dirptr = 16384; + my ($newdirlistref,$newlisterror) = + &Apache::lonnet::dirlist($currdir,$docudom,$docuname,1); + if (ref($newdirlistref) eq 'ARRAY') { + foreach my $dir_line (@{$newdirlistref}) { + my ($item,undef,undef,$testdir)=split(/\&/,$dir_line,5); + unless ($item =~ /^\.+$/) { + $$count ++; + @{$dirorder->{$$count}} = @{$hierarchy}; + $titles->{$$count} = $item; + &archive_hierarchy($$depth,$$count,$parent,$children); + + my $is_dir; + if ($dirptr&$testdir) { + $is_dir = 1; + } + if ($wantform) { + $result .= &archive_row($is_dir,$item,$currdir,$$depth,$$count); + } + if ($is_dir) { + $$depth ++; + push(@{$hierarchy},$$count); + $parent->{$$depth} = $$count; + $result .= + &recurse_extracted_archive("$currdir/$item",$docudom, + $docuname,$depth,$count, + $hierarchy,$dirorder,$children, + $parent,$titles,$wantform); + $$depth --; + pop(@{$hierarchy}); + } + } + } + } + return $result; +} + +sub archive_hierarchy { + my ($depth,$count,$parent,$children) =@_; + if ((ref($parent) eq 'HASH') && (ref($children) eq 'HASH')) { + if (exists($parent->{$depth})) { + $children->{$parent->{$depth}} .= $count.':'; + } + } + return; +} + +sub archive_row { + my ($is_dir,$item,$currdir,$depth,$count) = @_; + my ($name) = ($item =~ m{([^/]+)$}); + my %choices = &Apache::lonlocal::texthash ( + 'display' => 'Add as file', + 'dependency' => 'Include as dependency', + 'discard' => 'Discard', + ); + if ($is_dir) { + $choices{'display'} = &mt('Add as folder'); + } + my $output = &start_data_table_row().'
' x2)."\n";
+ }
+ if ($is_dir) {
+ $output .= '
'."\n".
+ ''."\n";
+ } else {
+ $output .= ''."\n";
+ }
+ $output .= ' '.$name.''; + } + } + for (my $i=1; $i<=$numitems; $i++) { + next unless ($env{'form.archive_'.$i} eq 'dependency'); + my $path = $env{'form.archive_content_'.$i}; + if ($path =~ /^\Q$pathtocheck\E/) { + my ($title) = ($path =~ m{/([^/]+)$}); + $referrer{$i} = $env{'form.archive_dependent_on_'.$i}; + if ($env{'form.archive_'.$referrer{$i}} eq 'display') { + if (ref($dirorder{$i}) eq 'ARRAY') { + my ($itemidx,$fullpath,$relpath); + if (ref($dirorder{$referrer{$i}}) eq 'ARRAY') { + my $container = $dirorder{$referrer{$i}}->[-1]; + for (my $j=0; $j<@{$dirorder{$i}}; $j++) { + if ($dirorder{$i}->[$j] eq $container) { + $itemidx = $j; + } + } + } + if ($itemidx eq '') { + $itemidx = 0; + } + if (grep(/^\Q$referrer{$i}\E$/,@archdirs)) { + if ($mapinner{$referrer{$i}}) { + $fullpath = "$prefix$dir/$docstype/$mapinner{$referrer{$i}}"; + for (my $j=$itemidx; $j<@{$dirorder{$i}}; $j++) { + if (grep(/^\Q$dirorder{$i}->[$j]\E$/,@archdirs)) { + unless (defined($newseqid{$dirorder{$i}->[$j]})) { + $fullpath .= '/'.$titles{$dirorder{$i}->[$j]}; + $relpath .= '/'.$titles{$dirorder{$i}->[$j]}; + if (!-e $fullpath) { + mkdir($fullpath,0755); + } + } + } else { + last; + } + } + } + } elsif ($newdest{$referrer{$i}}) { + $fullpath = $newdest{$referrer{$i}}; + for (my $j=$itemidx; $j<@{$dirorder{$i}}; $j++) { + if ($env{'form.archive_'.$dirorder{$i}->[$j]} eq 'discard') { + $orphaned{$i} = $env{'form.archive_'.$dirorder{$i}->[$j]}; + last; + } elsif (grep(/^\Q$dirorder{$i}->[$j]\E$/,@archdirs)) { + unless (defined($newseqid{$dirorder{$i}->[$j]})) { + $fullpath .= '/'.$titles{$dirorder{$i}->[$j]}; + $relpath .= '/'.$titles{$dirorder{$i}->[$j]}; + if (!-e $fullpath) { + mkdir($fullpath,0755); + } + } + } else { + last; + } + } + } + if ($fullpath ne '') { + if (-e "$prefix$path") { + system("mv $prefix$path $fullpath/$title"); + } + if (-e "$fullpath/$title") { + my $showpath; + if ($relpath ne '') { + $showpath = "$relpath/$title"; + } else { + $showpath = "/$title"; + } + $result .= '
'; + } + } else { + $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',$path).'
'; + } + } + if (keys(%todelete)) { + foreach my $key (keys(%todelete)) { + unlink($key); + } + } + if (keys(%todeletedir)) { + foreach my $key (keys(%todeletedir)) { + rmdir($key); + } + } + foreach my $dir (sort(keys(%is_dir))) { + if (($pathtocheck ne '') && ($dir ne '')) { + &cleanup_empty_dirs($prefix."$pathtocheck/$dir"); + } + } + if ($result ne '') { + $output .= '
- '."\n".
+ $result."\n".
+ '
'. + &mt('Course home server failed to retrieve:').'
- '.
+ $replicationfail.
+ '
'.&mt('Not extracted.').'
'.
+ $error.'
'.$warning.'
'."\n"; + } + return $output; +} + +sub cleanup_empty_dirs { + my ($path) = @_; + if (($path ne '') && (-d $path)) { + if (opendir(my $dirh,$path)) { + my @dircontents = grep(!/^\./,readdir($dirh)); + my $numitems = 0; + foreach my $item (@dircontents) { + if (-d "$path/$item") { + &cleanup_empty_dirs("$path/$item"); + if (-e "$path/$item") { + $numitems ++; + } + } else { + $numitems ++; + } + } + if ($numitems == 0) { + rmdir($path); + } + closedir($dirh); + } + } + return; +} + +=pod + +=item &get_folder_hierarchy() + +Provides hierarchy of names of folders/sub-folders containing the current +item, + +Inputs: 3 + - $navmap - navmaps object + + - $map - url for map (either the trigger itself, or map containing + the resource, which is the trigger). + + - $showitem - 1 => show title for map itself; 0 => do not show. + +Outputs: 1 @pathitems - array of folder/subfolder names. + +=cut + +sub get_folder_hierarchy { + my ($navmap,$map,$showitem) = @_; + my @pathitems; + if (ref($navmap)) { + my $mapres = $navmap->getResourceByUrl($map); + if (ref($mapres)) { + my $pcslist = $mapres->map_hierarchy(); + if ($pcslist ne '') { + my @pcs = split(/,/,$pcslist); + foreach my $pc (@pcs) { + if ($pc == 1) { + push(@pathitems,&mt('Main Course Documents')); + } else { + my $res = $navmap->getByMapPc($pc); + if (ref($res)) { + my $title = $res->compTitle(); + $title =~ s/\W+/_/g; + if ($title ne '') { + push(@pathitems,$title); + } + } + } + } + } + if ($showitem) { + if ($mapres->{ID} eq '0.0') { + push(@pathitems,&mt('Main Course Documents')); + } else { + my $maptitle = $mapres->compTitle(); + $maptitle =~ s/\W+/_/g; + if ($maptitle ne '') { + push(@pathitems,$maptitle); + } + } + } + } + } + return @pathitems; +} + +=pod + +=item * &get_turnedin_filepath() + +Determines path in a user's portfolio file for storage of files uploaded +to a specific essayresponse or dropbox item. + +Inputs: 3 required + 1 optional. +$symb is symb for resource, $uname and $udom are for current user (required). +$caller is optional (can be "submission", if routine is called when storing +an upoaded file when "Submit Answer" button was pressed). + +Returns array containing $path and $multiresp. +$path is path in portfolio. $multiresp is 1 if this resource contains more +than one file upload item. Callers of routine should append partid as a +subdirectory to $path in cases where $multiresp is 1. + +Called by: homework/essayresponse.pm and homework/structuretags.pm + +=cut + +sub get_turnedin_filepath { + my ($symb,$uname,$udom,$caller) = @_; + my ($map,$resid,$resurl)=&Apache::lonnet::decode_symb($symb); + my $turnindir; + my %userhash = &Apache::lonnet::userenvironment($udom,$uname,'turnindir'); + $turnindir = $userhash{'turnindir'}; + my ($path,$multiresp); + if ($turnindir eq '') { + if ($caller eq 'submission') { + $turnindir = &mt('turned in'); + $turnindir =~ s/\W+/_/g; + my %newhash = ( + 'turnindir' => $turnindir, + ); + &Apache::lonnet::put('environment',\%newhash,$udom,$uname); + } + } + if ($turnindir ne '') { + $path = '/'.$turnindir.'/'; + my ($multipart,$turnin,@pathitems); + my $navmap = Apache::lonnavmaps::navmap->new(); + if (defined($navmap)) { + my $mapres = $navmap->getResourceByUrl($map); + if (ref($mapres)) { + my $pcslist = $mapres->map_hierarchy(); + if ($pcslist ne '') { + foreach my $pc (split(/,/,$pcslist)) { + my $res = $navmap->getByMapPc($pc); + if (ref($res)) { + my $title = $res->compTitle(); + $title =~ s/\W+/_/g; + if ($title ne '') { + push(@pathitems,$title); + } + } + } + } + my $maptitle = $mapres->compTitle(); + $maptitle =~ s/\W+/_/g; + if ($maptitle ne '') { + push(@pathitems,$maptitle); + } + unless ($env{'request.state'} eq 'construct') { + my $res = $navmap->getBySymb($symb); + if (ref($res)) { + my $partlist = $res->parts(); + my $totaluploads = 0; + if (ref($partlist) eq 'ARRAY') { + foreach my $part (@{$partlist}) { + my @types = $res->responseType($part); + my @ids = $res->responseIds($part); + for (my $i=0; $i < scalar(@ids); $i++) { + if ($types[$i] eq 'essay') { + my $partid = $part.'_'.$ids[$i]; + if (&Apache::lonnet::EXT("resource.$partid.uploadedfiletypes") ne '') { + $totaluploads ++; + } + } + } + } + if ($totaluploads > 1) { + $multiresp = 1; + } + } + } + } + } else { + return; + } + } else { + return; + } + my $restitle=&Apache::lonnet::gettitle($symb); + $restitle =~ s/\W+/_/g; + if ($restitle eq '') { + $restitle = ($resurl =~ m{/[^/]+$}); + if ($restitle eq '') { + $restitle = time; + } + } + push(@pathitems,$restitle); + $path .= join('/',@pathitems); + } + return ($path,$multiresp); +} =pod @@ -9937,7 +13312,7 @@ sub commit_customrole { } sub commit_standardrole { - my ($udom,$uname,$url,$three,$start,$end,$one,$two,$sec,$context) = @_; + my ($udom,$uname,$url,$three,$start,$end,$one,$two,$sec,$context,$credits) = @_; my ($output,$logmsg,$linefeed); if ($context eq 'auto') { $linefeed = "\n"; @@ -9946,7 +13321,7 @@ sub commit_standardrole { } if ($three eq 'st') { my $result = &commit_studentrole(\$logmsg,$udom,$uname,$url,$three,$start,$end, - $one,$two,$sec,$context); + $one,$two,$sec,$context,$credits); if (($result =~ /^error/) || ($result eq 'not_in_class') || ($result eq 'unknown_course') || ($result eq 'refused')) { $output = $logmsg.' '.&mt('Error: ').$result."\n"; @@ -9977,7 +13352,8 @@ sub commit_standardrole { } sub commit_studentrole { - my ($logmsg,$udom,$uname,$url,$three,$start,$end,$one,$two,$sec,$context) = @_; + my ($logmsg,$udom,$uname,$url,$three,$start,$end,$one,$two,$sec,$context, + $credits) = @_; my ($result,$linefeed,$oldsecurl,$newsecurl); if ($context eq 'auto') { $linefeed = "\n"; @@ -10024,7 +13400,11 @@ sub commit_studentrole { } } if (($expire_role_result eq 'ok') || ($secchange == 0)) { - $modify_section_result = &Apache::lonnet::modify_student_enrollment($udom,$uname,undef,undef,undef,undef,undef,$sec,$end,$start,'','',$cid,'',$context); + $modify_section_result = + &Apache::lonnet::modify_student_enrollment($udom,$uname,undef,undef, + undef,undef,undef,$sec, + $end,$start,'','',$cid, + '',$context,$credits); if ($modify_section_result =~ /^ok/) { if ($secchange == 1) { if ($sec eq '') { @@ -10046,7 +13426,7 @@ sub commit_studentrole { } } } else { - if ($secchange) { + if ($secchange) { $$logmsg .= &mt('Error when attempting section change for [_1] from old section "[_2]" to new section: "[_3]" in course [_4] -error:',$uname,$oldsec,$sec,$cid).' '.$modify_section_result.$linefeed; } else { $$logmsg .= &mt('Error when attempting to modify role for [_1] for section: "[_2]" in course [_3] -error:',$uname,$sec,$cid).' '.$modify_section_result.$linefeed; @@ -10055,7 +13435,7 @@ sub commit_studentrole { $result = $modify_section_result; } elsif ($secchange == 1) { if ($oldsec eq '') { - $$logmsg .= &mt('Error when attempting to expire existing role without a section for [_1] in course [_3] -error: ',$uname,$cid).' '.$expire_role_result.$linefeed; + $$logmsg .= &mt('Error when attempting to expire existing role without a section for [_1] in course [_2] -error: ',$uname,$cid).' '.$expire_role_result.$linefeed; } else { $$logmsg .= &mt('Error when attempting to expire existing role for [_1] in section [_2] in course [_3] -error: ',$uname,$oldsec,$cid).' '.$expire_role_result.$linefeed; } @@ -10081,6 +13461,26 @@ sub commit_studentrole { return $result; } +sub show_role_extent { + my ($scope,$context,$role) = @_; + $scope =~ s{^/}{}; + my @courseroles = &Apache::lonuserutils::roles_by_context('course',1); + push(@courseroles,'co'); + my @authorroles = &Apache::lonuserutils::roles_by_context('author'); + if (($context eq 'course') || (grep(/^\Q$role\E/,@courseroles))) { + $scope =~ s{/}{_}; + return ''.$env{'course.'.$scope.'.description'}.''; + } elsif (($context eq 'author') || (grep(/^\Q$role\E/,@authorroles))) { + my ($audom,$auname) = split(/\//,$scope); + return &mt('[_1] Author Space',''. + &Apache::loncommon::plainname($auname,$audom).''); + } else { + $scope =~ s{/$}{}; + return &mt('Domain: [_1]',''. + &Apache::lonnet::domain($scope,'description').''); + } +} + ############################################################ ############################################################ @@ -10225,6 +13625,10 @@ sub construct_course { $cenv{'url'}=$oldcenv{'url'}; # Restore title $cenv{'description'}=$oldcenv{'description'}; +# Restore creation date, creator and creation context. + $cenv{'internal.created'}=$oldcenv{'internal.created'}; + $cenv{'internal.creator'}=$oldcenv{'internal.creator'}; + $cenv{'internal.creationcontext'}=$oldcenv{'internal.creationcontext'}; # Mark as cloned $cenv{'clonedfrom'}=$cloneid; # Need to clone grading mode @@ -10240,6 +13644,7 @@ sub construct_course { 'pch.users.denied', 'plc.users.denied', 'hidefromcat', + 'checkforpriv', 'categories'], $$crsudom,$$crsunum); } @@ -10269,6 +13674,9 @@ sub construct_course { } else { $cenv{'internal.courseowner'} = $args->{'curruser'}; } + if ($args->{'defaultcredits'}) { + $cenv{'internal.defaultcredits'} = $args->{'defaultcredits'}; + } my @badclasses = (); # Used to accumulate sections/crosslistings that did not pass classlist access check for course owner. if ($args->{'crssections'}) { $cenv{'internal.sectionnums'} = ''; @@ -10293,6 +13701,11 @@ sub construct_course { # do not hide course coordinator from staff listing, # even if privileged $cenv{'nothideprivileged'}=$args->{'ccuname'}.':'.$args->{'ccdomain'}; +# add course coordinator's domain to domains to check for privileged users +# if different to course domain + if ($$crsudom ne $args->{'ccdomain'}) { + $cenv{'checkforpriv'} = $args->{'ccdomain'}; + } # add crosslistings if ($args->{'crsxlist'}) { $cenv{'internal.crosslistings'}=''; @@ -10471,7 +13884,7 @@ sub construct_course { $title=&mt('Syllabus'); $url='/public/'.$$crsudom.'/'.$$crsunum.'/syllabus'; } else { - $title=&mt('Navigate Contents'); + $title=&mt('Table of Contents'); $url='/adm/navmaps'; } @@ -10488,6 +13901,8 @@ sub construct_course { ############################################################ ############################################################ +#SD +# only Community and Course, or anything else? sub course_type { my ($cid) = @_; if (!defined($cid)) { @@ -10603,7 +14018,7 @@ sub init_user_environment { # See if old ID present, if so, remove - my ($filename,$cookie,$userroles); + my ($filename,$cookie,$userroles,$firstaccenv,$timerintenv); my $now=time; if ($public) { @@ -10641,7 +14056,8 @@ sub init_user_environment { # Initialize roles - $userroles=&Apache::lonnet::rolesinit($domain,$username,$authhost); + ($userroles,$firstaccenv,$timerintenv) = + &Apache::lonnet::rolesinit($domain,$username,$authhost); } # ------------------------------------ Check browser type and MathML capability @@ -10696,24 +14112,52 @@ sub init_user_environment { $env{'browser.interface'}=$form->{'interface'}; } - foreach my $tool ('aboutme','blog','portfolio') { + my %is_adv = ( is_adv => $env{'user.adv'} ); + my %domdef; + unless ($domain eq 'public') { + %domdef = &Apache::lonnet::get_domain_defaults($domain); + } + + foreach my $tool ('aboutme','blog','webdav','portfolio') { $userenv{'availabletools.'.$tool} = - &Apache::lonnet::usertools_access($username,$domain,$tool,'reload'); + &Apache::lonnet::usertools_access($username,$domain,$tool,'reload', + undef,\%userenv,\%domdef,\%is_adv); } foreach my $crstype ('official','unofficial','community') { $userenv{'canrequest.'.$crstype} = &Apache::lonnet::usertools_access($username,$domain,$crstype, - 'reload','requestcourses'); + 'reload','requestcourses', + \%userenv,\%domdef,\%is_adv); + } + + $userenv{'canrequest.author'} = + &Apache::lonnet::usertools_access($username,$domain,'requestauthor', + 'reload','requestauthor', + \%userenv,\%domdef,\%is_adv); + my %reqauthor = &Apache::lonnet::get('requestauthor',['author_status','author'], + $domain,$username); + my $reqstatus = $reqauthor{'author_status'}; + if ($reqstatus eq 'approval' || $reqstatus eq 'approved') { + if (ref($reqauthor{'author'}) eq 'HASH') { + $userenv{'requestauthorqueued'} = $reqstatus.':'. + $reqauthor{'author'}{'timestamp'}; + } } $env{'user.environment'} = "$lonids/$cookie.id"; - + if (tie(my %disk_env,'GDBM_File',"$lonids/$cookie.id", &GDBM_WRCREAT(),0640)) { &_add_to_env(\%disk_env,\%initial_env); &_add_to_env(\%disk_env,\%userenv,'environment.'); &_add_to_env(\%disk_env,$userroles); + if (ref($firstaccenv) eq 'HASH') { + &_add_to_env(\%disk_env,$firstaccenv); + } + if (ref($timerintenv) eq 'HASH') { + &_add_to_env(\%disk_env,$timerintenv); + } if (ref($args->{'extra_env'})) { &_add_to_env(\%disk_env,$args->{'extra_env'}); } @@ -10749,7 +14193,9 @@ sub get_symb { my $symb=($env{'form.symb'} ne '' ? $env{'form.symb'} : (&Apache::lonnet::symbread($url))); if ($symb eq '') { if (!$silent) { - $request->print("Unable to handle ambiguous references:$url:."); + if (ref($request)) { + $request->print("Unable to handle ambiguous references:$url:."); + } return (); } } @@ -10783,6 +14229,348 @@ sub clean_symb { return ($symb,$enc); } +sub build_release_hashes { + my ($checkparms,$checkresponsetypes,$checkcrstypes,$anonsurvey,$randomizetry) = @_; + return unless((ref($checkparms) eq 'HASH') && (ref($checkresponsetypes) eq 'HASH') && + (ref($checkcrstypes) eq 'HASH') && (ref($anonsurvey) eq 'HASH') && + (ref($randomizetry) eq 'HASH')); + foreach my $key (keys(%Apache::lonnet::needsrelease)) { + my ($item,$name,$value) = split(/:/,$key); + if ($item eq 'parameter') { + if (ref($checkparms->{$name}) eq 'ARRAY') { + unless(grep(/^\Q$name\E$/,@{$checkparms->{$name}})) { + push(@{$checkparms->{$name}},$value); + } + } else { + push(@{$checkparms->{$name}},$value); + } + } elsif ($item eq 'resourcetag') { + if ($name eq 'responsetype') { + $checkresponsetypes->{$value} = $Apache::lonnet::needsrelease{$key} + } + } elsif ($item eq 'course') { + if ($name eq 'crstype') { + $checkcrstypes->{$value} = $Apache::lonnet::needsrelease{$key}; + } + } + } + ($anonsurvey->{major},$anonsurvey->{minor}) = split(/\./,$Apache::lonnet::needsrelease{'parameter:type:anonsurvey'}); + ($randomizetry->{major},$randomizetry->{minor}) = split(/\./,$Apache::lonnet::needsrelease{'parameter:type:randomizetry'}); + return; +} + +sub update_content_constraints { + my ($cdom,$cnum,$chome,$cid) = @_; + my %curr_reqd_hash = &Apache::lonnet::userenvironment($cdom,$cnum,'internal.releaserequired'); + my ($reqdmajor,$reqdminor) = split(/\./,$curr_reqd_hash{'internal.releaserequired'}); + my %checkresponsetypes; + foreach my $key (keys(%Apache::lonnet::needsrelease)) { + my ($item,$name,$value) = split(/:/,$key); + if ($item eq 'resourcetag') { + if ($name eq 'responsetype') { + $checkresponsetypes{$value} = $Apache::lonnet::needsrelease{$key} + } + } + } + my $navmap = Apache::lonnavmaps::navmap->new(); + if (defined($navmap)) { + my %allresponses; + foreach my $res ($navmap->retrieveResources(undef,sub { $_[0]->is_problem() },1,0)) { + my %responses = $res->responseTypes(); + foreach my $key (keys(%responses)) { + next unless(exists($checkresponsetypes{$key})); + $allresponses{$key} += $responses{$key}; + } + } + foreach my $key (keys(%allresponses)) { + my ($major,$minor) = split(/\./,$checkresponsetypes{$key}); + if (($major > $reqdmajor) || ($major == $reqdmajor && $minor > $reqdminor)) { + ($reqdmajor,$reqdminor) = ($major,$minor); + } + } + undef($navmap); + } + unless (($reqdmajor eq '') && ($reqdminor eq '')) { + &Apache::lonnet::update_released_required($reqdmajor.'.'.$reqdminor,$cdom,$cnum,$chome,$cid); + } + return; +} + +sub allmaps_incourse { + my ($cdom,$cnum,$chome,$cid) = @_; + if ($cdom eq '' || $cnum eq '' || $chome eq '' || $cid eq '') { + $cid = $env{'request.course.id'}; + $cdom = $env{'course.'.$cid.'.domain'}; + $cnum = $env{'course.'.$cid.'.num'}; + $chome = $env{'course.'.$cid.'.home'}; + } + my %allmaps = (); + my $lastchange = + &Apache::lonnet::get_coursechange($cdom,$cnum); + if ($lastchange > $env{'request.course.tied'}) { + my ($furl,$ferr) = &Apache::lonuserstate::readmap("$cdom/$cnum"); + unless ($ferr) { + &update_content_constraints($cdom,$cnum,$chome,$cid); + } + } + my $navmap = Apache::lonnavmaps::navmap->new(); + if (defined($navmap)) { + foreach my $res ($navmap->retrieveResources(undef,sub { $_[0]->is_map() },1,0,1)) { + $allmaps{$res->src()} = 1; + } + } + return \%allmaps; +} + +sub parse_supplemental_title { + my ($title) = @_; + + my ($foldertitle,$renametitle); + if ($title =~ /&&&/) { + $title = &HTML::Entites::decode($title); + } + if ($title =~ m/^(\d+)___&&&___($match_username)___&&&___($match_domain)___&&&___(.*)$/) { + $renametitle=$4; + my ($time,$uname,$udom) = ($1,$2,$3); + $foldertitle=&Apache::lontexconvert::msgtexconverted($4); + my $name = &plainname($uname,$udom); + $name = &HTML::Entities::encode($name,'"<>&\''); + $renametitle = &HTML::Entities::encode($renametitle,'"<>&\''); + $title=''.&Apache::lonlocal::locallocaltime($time).' '. + $name.':'.$foldertitle; + } + if (wantarray) { + return ($title,$foldertitle,$renametitle); + } + return $title; +} + +sub symb_to_docspath { + my ($symb) = @_; + return unless ($symb); + my ($mapurl,$id,$resurl) = &Apache::lonnet::decode_symb($symb); + if ($resurl=~/\.(sequence|page)$/) { + $mapurl=$resurl; + } elsif ($resurl eq 'adm/navmaps') { + $mapurl=$env{'course.'.$env{'request.course.id'}.'.url'}; + } + my $mapresobj; + my $navmap = Apache::lonnavmaps::navmap->new(); + if (ref($navmap)) { + $mapresobj = $navmap->getResourceByUrl($mapurl); + } + $mapurl=~s{^.*/([^/]+)\.(\w+)$}{$1}; + my $type=$2; + my $path; + if (ref($mapresobj)) { + my $pcslist = $mapresobj->map_hierarchy(); + if ($pcslist ne '') { + foreach my $pc (split(/,/,$pcslist)) { + next if ($pc <= 1); + my $res = $navmap->getByMapPc($pc); + if (ref($res)) { + my $thisurl = $res->src(); + $thisurl=~s{^.*/([^/]+)\.\w+$}{$1}; + my $thistitle = $res->title(); + $path .= '&'. + &Apache::lonhtmlcommon::entity_encode($thisurl).'&'. + &Apache::lonhtmlcommon::entity_encode($thistitle). + ':'.$res->randompick(). + ':'.$res->randomout(). + ':'.$res->encrypted(). + ':'.$res->randomorder(). + ':'.$res->is_page(); + } + } + } + $path =~ s/^\&//; + my $maptitle = $mapresobj->title(); + if ($mapurl eq 'default') { + $maptitle = 'Main Course Documents'; + } + $path .= (($path ne '')? '&' : ''). + &Apache::lonhtmlcommon::entity_encode($mapurl).'&'. + &Apache::lonhtmlcommon::entity_encode($maptitle). + ':'.$mapresobj->randompick(). + ':'.$mapresobj->randomout(). + ':'.$mapresobj->encrypted(). + ':'.$mapresobj->randomorder(). + ':'.$mapresobj->is_page(); + } else { + my $maptitle = &Apache::lonnet::gettitle($mapurl); + my $ispage = (($type eq 'page')? 1 : ''); + if ($mapurl eq 'default') { + $maptitle = 'Main Course Documents'; + } + $path = &Apache::lonhtmlcommon::entity_encode($mapurl).'&'. + &Apache::lonhtmlcommon::entity_encode($maptitle).':::::'.$ispage; + } + unless ($mapurl eq 'default') { + $path = 'default&'. + &Apache::lonhtmlcommon::entity_encode('Main Course Documents'). + ':::::&'.$path; + } + return $path; +} + +sub captcha_display { + my ($context,$lonhost) = @_; + my ($output,$error); + my ($captcha,$pubkey,$privkey) = &get_captcha_config($context,$lonhost); + if ($captcha eq 'original') { + $output = &create_captcha(); + unless ($output) { + $error = 'captcha'; + } + } elsif ($captcha eq 'recaptcha') { + $output = &create_recaptcha($pubkey); + unless ($output) { + $error = 'recaptcha'; + } + } + return ($output,$error); +} + +sub captcha_response { + my ($context,$lonhost) = @_; + my ($captcha_chk,$captcha_error); + my ($captcha,$pubkey,$privkey) = &get_captcha_config($context,$lonhost); + if ($captcha eq 'original') { + ($captcha_chk,$captcha_error) = &check_captcha(); + } elsif ($captcha eq 'recaptcha') { + $captcha_chk = &check_recaptcha($privkey); + } else { + $captcha_chk = 1; + } + return ($captcha_chk,$captcha_error); +} + +sub get_captcha_config { + my ($context,$lonhost) = @_; + my ($captcha,$pubkey,$privkey,$hashtocheck); + my $hostname = &Apache::lonnet::hostname($lonhost); + my $serverhomeID = &Apache::lonnet::get_server_homeID($hostname); + my $serverhomedom = &Apache::lonnet::host_domain($serverhomeID); + if ($context eq 'usercreation') { + my %domconfig = &Apache::lonnet::get_dom('configuration',[$context],$serverhomedom); + if (ref($domconfig{$context}) eq 'HASH') { + $hashtocheck = $domconfig{$context}{'cancreate'}; + if (ref($hashtocheck) eq 'HASH') { + if ($hashtocheck->{'captcha'} eq 'recaptcha') { + if (ref($hashtocheck->{'recaptchakeys'}) eq 'HASH') { + $pubkey = $hashtocheck->{'recaptchakeys'}{'public'}; + $privkey = $hashtocheck->{'recaptchakeys'}{'private'}; + } + if ($privkey && $pubkey) { + $captcha = 'recaptcha'; + } else { + $captcha = 'original'; + } + } elsif ($hashtocheck->{'captcha'} ne 'notused') { + $captcha = 'original'; + } + } + } else { + $captcha = 'captcha'; + } + } elsif ($context eq 'login') { + my %domconfhash = &Apache::loncommon::get_domainconf($serverhomedom); + if ($domconfhash{$serverhomedom.'.login.captcha'} eq 'recaptcha') { + $pubkey = $domconfhash{$serverhomedom.'.login.recaptchakeys_public'}; + $privkey = $domconfhash{$serverhomedom.'.login.recaptchakeys_private'}; + if ($privkey && $pubkey) { + $captcha = 'recaptcha'; + } else { + $captcha = 'original'; + } + } elsif ($domconfhash{$serverhomedom.'.login.captcha'} eq 'original') { + $captcha = 'original'; + } + } + return ($captcha,$pubkey,$privkey); +} + +sub create_captcha { + my %captcha_params = &captcha_settings(); + my ($output,$maxtries,$tries) = ('',10,0); + while ($tries < $maxtries) { + $tries ++; + my $captcha = Authen::Captcha->new ( + output_folder => $captcha_params{'output_dir'}, + data_folder => $captcha_params{'db_dir'}, + ); + my $md5sum = $captcha->generate_code($captcha_params{'numchars'}); + + if (-e $Apache::lonnet::perlvar{'lonCaptchaDir'}.'/'.$md5sum.'.png') { + $output = ''."\n". + &mt('Type in the letters/numbers shown below').' '. + '
'. + '
';
+ last;
+ }
+ }
+ return $output;
+}
+
+sub captcha_settings {
+ my %captcha_params = (
+ output_dir => $Apache::lonnet::perlvar{'lonCaptchaDir'},
+ www_output_dir => "/captchaspool",
+ db_dir => $Apache::lonnet::perlvar{'lonCaptchaDb'},
+ numchars => '5',
+ );
+ return %captcha_params;
+}
+
+sub check_captcha {
+ my ($captcha_chk,$captcha_error);
+ my $code = $env{'form.code'};
+ my $md5sum = $env{'form.crypt'};
+ my %captcha_params = &captcha_settings();
+ my $captcha = Authen::Captcha->new(
+ output_folder => $captcha_params{'output_dir'},
+ data_folder => $captcha_params{'db_dir'},
+ );
+ $captcha_chk = $captcha->check_code($code,$md5sum);
+ my %captcha_hash = (
+ 0 => 'Code not checked (file error)',
+ -1 => 'Failed: code expired',
+ -2 => 'Failed: invalid code (not in database)',
+ -3 => 'Failed: invalid code (code does not match crypt)',
+ );
+ if ($captcha_chk != 1) {
+ $captcha_error = $captcha_hash{$captcha_chk}
+ }
+ return ($captcha_chk,$captcha_error);
+}
+
+sub create_recaptcha {
+ my ($pubkey) = @_;
+ my $captcha = Captcha::reCAPTCHA->new;
+ return $captcha->get_options_setter({theme => 'white'})."\n".
+ $captcha->get_html($pubkey).
+ &mt('If either word is hard to read, [_1] will replace them.',
+ ''; +} + +sub check_recaptcha { + my ($privkey) = @_; + my $captcha_chk; + my $captcha = Captcha::reCAPTCHA->new; + my $captcha_result = + $captcha->check_answer( + $privkey, + $ENV{'REMOTE_ADDR'}, + $env{'form.recaptcha_challenge_field'}, + $env{'form.recaptcha_response_field'}, + ); + if ($captcha_result->{is_valid}) { + $captcha_chk = 1; + } + return $captcha_chk; +} + =pod =back