+ $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); @@ -7256,8 +8102,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'; @@ -8159,7 +9004,10 @@ sub user_rule_formats { my ($rules,$ruleorder) = &Apache::lonnet::inst_userrules($domain,$check); if ((ref($rules) eq 'HASH') && (ref($ruleorder) eq 'ARRAY')) { if (@{$ruleorder} > 0) { - $output = ''.&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})) {
@@ -8313,7 +9161,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:
@@ -8323,15 +9172,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
@@ -8339,13 +9189,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;}
@@ -8355,9 +9208,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
@@ -8496,13 +9476,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'}) {
@@ -8530,8 +9521,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();
@@ -8570,25 +9585,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;
@@ -8599,6 +9635,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')) {
@@ -8615,9 +9668,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;
}
@@ -8627,41 +9700,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) = @_; @@ -8843,7 +10066,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; @@ -8900,13 +10122,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]',''. @@ -8928,15 +10152,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 { @@ -8971,7 +10197,7 @@ sub modify_html_form { ''. &end_data_table_row(); - } + } } } else { $modifyform = $pathchgtable; @@ -8982,6 +10208,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". @@ -9010,23 +10239,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); @@ -9060,13 +10321,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].', @@ -9093,7 +10355,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 { @@ -9249,6 +10515,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") { + &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() @@ -10840,7 +13272,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; } @@ -10866,6 +13298,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').''); + } +} + ############################################################ ############################################################ @@ -11394,7 +13846,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) { @@ -11432,7 +13884,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 @@ -11493,7 +13946,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); @@ -11506,13 +13959,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'}); } @@ -11548,7 +14021,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 (); } } @@ -11612,6 +14087,318 @@ 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 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