+ $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,<";
+ if ($bgcolor ne '') {
+ $tdcol = "background-color: $bgcolor;";
+ }
+ return <<"END";
+
|
'.&mt($msg).'
'. &Apache::loncommon::end_page(); if (ref($r)) { $r->print($page); @@ -7286,8 +8070,7 @@ role status: active, previous or future. sub check_user_status { my ($udom,$uname,$cdom,$crs,$role,$sec) = @_; - my $extra = &Apache::lonnet::freeze_escape({'skipcheck' => 1}); - my %userinfo = &Apache::lonnet::dump('roles',$udom,$uname,'.',undef,$extra); + my %userinfo = &Apache::lonnet::dump('roles',$udom,$uname); my @uroles = keys %userinfo; my $srchstr; my $active_chk = 'none'; @@ -8343,7 +9126,8 @@ sub get_standard_codeitems { =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: @@ -8353,15 +9137,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 @@ -8369,13 +9154,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;} @@ -8385,9 +9173,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 @@ -8526,13 +9441,24 @@ sub get_env_multiple { sub ask_for_embedded_content { my ($actionurl,$state,$allfiles,$codebase,$args)=@_; - my (%subdependencies,%dependencies,%mapping,%existing,%newfiles,%pathchanges); - my $num = 0; + my (%subdependencies,%dependencies,%mapping,%existing,%newfiles,%pathchanges, + %currsubfile,%unused,$rem); + my $counter = 0; + my $numnew = 0; my $numremref = 0; my $numinvalid = 0; my $numpathchg = 0; my $numexisting = 0; - my ($output,$upload_output,$toplevel,$url,$udom,$uname,$getpropath); + my $numunused = 0; + my ($output,$upload_output,$toplevel,$url,$udom,$uname,$getpropath,$cdom,$cnum, + $fileloc,$filename,$delete_output,$modify_output,$title,$symb,$path); + my $heading = &mt('Upload embedded files'); + my $buttontext = &mt('Upload'); + + my $navmap; + if ($env{'request.course.id'}) { + $navmap = Apache::lonnavmaps::navmap->new(); + } if (($actionurl eq '/adm/portfolio') || ($actionurl eq '/adm/coursegrp_portfolio')) { my $current_path='/'; if ($env{'form.currentpath'}) { @@ -8560,8 +9486,32 @@ sub ask_for_embedded_content { } } elsif ($actionurl eq '/adm/coursedocs') { if (ref($args) eq 'HASH') { - $url = $args->{'docs_url'}; - $toplevel = $url; + $url = $args->{'docs_url'}; + $toplevel = $url; + if ($args->{'context'} eq 'paste') { + ($cdom,$cnum) = ($url =~ m{^\Q/uploaded/\E($match_domain)/($match_courseid)/}); + ($path) = + ($toplevel =~ m{^(\Q/uploaded/$cdom/$cnum/\E(?:docs|supplemental)/(?:default|\d+)/\d+)/}); + $fileloc = &Apache::lonnet::filelocation('',$toplevel); + $fileloc =~ s{^/}{}; + } + } + } elsif ($actionurl eq '/adm/dependencies') { + if ($env{'request.course.id'} ne '') { + $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; + $cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; + if (ref($args) eq 'HASH') { + $url = $args->{'docs_url'}; + $title = $args->{'docs_title'}; + $toplevel = "/$url"; + ($rem) = ($toplevel =~ m{^(.+/)[^/]+$}); + ($path) = + ($toplevel =~ m{^(\Q/uploaded/$cdom/$cnum/\E(?:docs|supplemental)/(?:default|\d+)/\d+)/}); + $fileloc = &Apache::lonnet::filelocation('',$toplevel); + $fileloc =~ s{^/}{}; + ($filename) = ($fileloc =~ m{.+/([^/]+)$}); + $heading = &mt('Status of dependencies in [_1]',"$title ($filename)"); + } } } my $now = time(); @@ -8600,25 +9550,46 @@ sub ask_for_embedded_content { } } } + my $dirptr = 16384; foreach my $path (keys(%subdependencies)) { - my %currsubfile; + $currsubfile{$path} = {}; if (($actionurl eq '/adm/portfolio') || ($actionurl eq '/adm/coursegrp_portfolio')) { my ($sublistref,$listerror) = &Apache::lonnet::dirlist($url.$path,$udom,$uname,$getpropath); if (ref($sublistref) eq 'ARRAY') { foreach my $line (@{$sublistref}) { my ($file_name,$rest) = split(/\&/,$line,2); - $currsubfile{$file_name} = 1; + $currsubfile{$path}{$file_name} = 1; } } } elsif (($actionurl eq '/adm/upload') || ($actionurl eq '/adm/testbank')) { if (opendir(my $dir,$url.'/'.$path)) { my @subdir_list = grep(!/^\./,readdir($dir)); - map {$currsubfile{$_} = 1;} @subdir_list; + map {$currsubfile{$path}{$_} = 1;} @subdir_list; + } + } elsif (($actionurl eq '/adm/dependencies') || + (($actionurl eq '/adm/coursedocs') && (ref($args) eq 'HASH') && + ($args->{'context'} eq 'paste'))) { + if ($env{'request.course.id'} ne '') { + my ($dir) = ($fileloc =~ m{^(.+/)[^/]+$}); + if ($dir ne '') { + my ($sublistref,$listerror) = + &Apache::lonnet::dirlist($dir.$path,$cdom,$cnum,$getpropath,undef,'/'); + if (ref($sublistref) eq 'ARRAY') { + foreach my $line (@{$sublistref}) { + my ($file_name,$dom,undef,$testdir,undef,undef,undef,undef,$size, + undef,$mtime)=split(/\&/,$line,12); + unless (($testdir&$dirptr) || + ($file_name =~ /^\.\.?$/)) { + $currsubfile{$path}{$file_name} = [$size,$mtime]; + } + } + } + } } } foreach my $file (keys(%{$subdependencies{$path}})) { - if ($currsubfile{$file}) { + if (exists($currsubfile{$path}{$file})) { my $item = $path.'/'.$file; unless ($mapping{$item} eq $item) { $pathchanges{$item} = 1; @@ -8629,6 +9600,23 @@ sub ask_for_embedded_content { $newfiles{$path.'/'.$file} = 1; } } + if ($actionurl eq '/adm/dependencies') { + foreach my $path (keys(%currsubfile)) { + if (ref($currsubfile{$path}) eq 'HASH') { + foreach my $file (keys(%{$currsubfile{$path}})) { + unless ($subdependencies{$path}{$file}) { + next if (($rem ne '') && + (($env{"httpref.$rem"."$path/$file"} ne '') || + (ref($navmap) && + (($navmap->getResourceByUrl($rem."$path/$file") ne '') || + (($file =~ /^(.*\.s?html?)\.bak$/i) && + ($navmap->getResourceByUrl($rem."$path/$1"))))))); + $unused{$path.'/'.$file} = 1; + } + } + } + } + } } my %currfile; if (($actionurl eq '/adm/portfolio') || ($actionurl eq '/adm/coursegrp_portfolio')) { @@ -8645,9 +9633,29 @@ sub ask_for_embedded_content { my @dir_list = grep(!/^\./,readdir($dir)); map {$currfile{$_} = 1;} @dir_list; } + } elsif (($actionurl eq '/adm/dependencies') || + (($actionurl eq '/adm/coursedocs') && (ref($args) eq 'HASH') && + ($args->{'context'} eq 'paste'))) { + if ($env{'request.course.id'} ne '') { + my ($dir) = ($fileloc =~ m{^(.+/)[^/]+$}); + if ($dir ne '') { + my ($dirlistref,$listerror) = + &Apache::lonnet::dirlist($dir,$cdom,$cnum,$getpropath,undef,'/'); + if (ref($dirlistref) eq 'ARRAY') { + foreach my $line (@{$dirlistref}) { + my ($file_name,$dom,undef,$testdir,undef,undef,undef,undef, + $size,undef,$mtime)=split(/\&/,$line,12); + unless (($testdir&$dirptr) || + ($file_name =~ /^\.\.?$/)) { + $currfile{$file_name} = [$size,$mtime]; + } + } + } + } + } } foreach my $file (keys(%dependencies)) { - if ($currfile{$file}) { + if (exists($currfile{$file})) { unless ($mapping{$file} eq $file) { $pathchanges{$file} = 1; } @@ -8657,41 +9665,124 @@ sub ask_for_embedded_content { $newfiles{$file} = 1; } } + foreach my $file (keys(%currfile)) { + unless (($file eq $filename) || + ($file eq $filename.'.bak') || + ($dependencies{$file})) { + if ($actionurl eq '/adm/dependencies') { + next if (($rem ne '') && + (($env{"httpref.$rem".$file} ne '') || + (ref($navmap) && + (($navmap->getResourceByUrl($rem.$file) ne '') || + (($file =~ /^(.*\.s?html?)\.bak$/i) && + ($navmap->getResourceByUrl($rem.$1))))))); + } + $unused{$file} = 1; + } + } + if (($actionurl eq '/adm/coursedocs') && (ref($args) eq 'HASH') && + ($args->{'context'} eq 'paste')) { + $counter = scalar(keys(%existing)); + $numpathchg = scalar(keys(%pathchanges)); + return ($output,$counter,$numpathchg,\%existing); + } foreach my $embed_file (sort {lc($a) cmp lc($b)} keys(%newfiles)) { + if ($actionurl eq '/adm/dependencies') { + next if ($embed_file =~ m{^\w+://}); + } $upload_output .= &start_data_table_row(). - ''.&mt('changed from: [_1]',$mapping{$embed_file}).''; } $upload_output .= '
'.&mt('or').'
'; } } - return ($output,$num,$numpathchg); + return ($output,$counter,$numpathchg); } sub embedded_file_element { - my ($context,$num,$embed_file,$mapping,$allfiles,$codebase) = @_; + 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') { + if (($context eq 'upload_embedded') && ($type ne 'delete')) { $output = ''."\n"; } $output .= ' 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,$hiddenstate,$actionurl) = @_; @@ -8873,7 +10031,6 @@ sub upload_embedded { $output .= &mt('File name 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; if ($context eq 'portfolio') { my $result; @@ -8930,13 +10087,15 @@ 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 { $output .= &mt('Uploaded [_1]',''. @@ -8958,15 +10117,17 @@ sub upload_embedded { } $output .= &modify_html_form('upload_embedded',$actionurl,$hiddenstate,\%pathchange); $returnflag = 'ok'; - if (keys(%pathchange) > 0) { + 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).','','').'
'; + $output .= ''.&mt('Or [_1]continue[_2] the testbank import without modifying the reference(s).', + '','').'
'; $returnflag = 'modify_orightml'; } } - return ($output.$footer,$returnflag); + return ($output.$footer,$returnflag,$numpathchgs); } sub modify_html_form { @@ -9001,7 +10162,7 @@ sub modify_html_form { ''. &end_data_table_row(); - } + } } } else { $modifyform = $pathchgtable; @@ -9012,6 +10173,9 @@ sub modify_html_form { } } if ($modifyform) { + if ($actionurl eq '/adm/dependencies') { + $hiddenstate .= ''; + } return ''.&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". @@ -9040,23 +10204,55 @@ sub modify_html_refs { $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"; } else { $container = $Apache::lonnet::perlvar{'lonDocRoot'}.$env{'form.filename'}; } my (%allfiles,%codebase,$output,$content); my @changes = &get_env_multiple('form.namechange'); - return unless (@changes > 0); - if (($context eq 'portfolio') || ($context eq 'coursedoc')) { - return unless ($container =~ m{^/uploaded/\Q$udom\E/\Q$uname\E/}); + unless (@changes > 0) { + if (wantarray) { + return ('',0,0); + } else { + return; + } + } + if (($context eq 'portfolio') || ($context eq 'coursedoc') || + ($context eq 'manage_dependencies')) { + unless ($container =~ m{^/uploaded/\Q$udom\E/\Q$uname\E/}) { + if (wantarray) { + return ('',0,0); + } else { + return; + } + } $content = &Apache::lonnet::getfile($container); - return if ($content eq '-1'); + if ($content eq '-1') { + if (wantarray) { + return ('',0,0); + } else { + return; + } + } } else { - return unless ($container =~ /^\Q$dir_root\E/); + unless ($container =~ /^\Q$dir_root\E/) { + if (wantarray) { + return ('',0,0); + } else { + return; + } + } if (open(my $fh,"<$container")) { $content = join('', <$fh>); close($fh); } else { - return; + if (wantarray) { + return ('',0,0); + } else { + return; + } } } my ($count,$codebasecount) = (0,0); @@ -9090,13 +10286,14 @@ sub modify_html_refs { } if ($count || $codebasecount) { my $saveresult; - if ($context eq 'portfolio' || $context eq 'coursedoc') { + if (($context eq 'portfolio') || ($context eq 'coursedoc') || + ($context eq 'manage_dependencies')) { 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.'').'
'; + $fname.''. &mt('Error: update failed for: [_1].', @@ -9123,7 +10320,11 @@ sub modify_html_refs { ' to modify references: '.$parse_result); } } - return $output; + if (wantarray) { + return ($output,$count,$codebasecount); + } else { + return $output; + } } sub check_for_existing { @@ -9279,6 +10480,1172 @@ sub check_for_traversal { 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('File name 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") { + &recurse_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() @@ -11424,7 +13791,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) { @@ -11462,7 +13829,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 @@ -11523,7 +13891,7 @@ sub init_user_environment { %domdef = &Apache::lonnet::get_domain_defaults($domain); } - foreach my $tool ('aboutme','blog','portfolio') { + foreach my $tool ('aboutme','blog','webdav','portfolio') { $userenv{'availabletools.'.$tool} = &Apache::lonnet::usertools_access($username,$domain,$tool,'reload', undef,\%userenv,\%domdef,\%is_adv); @@ -11536,13 +13904,33 @@ sub init_user_environment { \%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'}); } @@ -11578,7 +13966,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 (); } } @@ -11642,6 +14032,224 @@ sub build_release_hashes { 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 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 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'},
+ );
+ my $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