--- loncom/interface/loncommon.pm 2009/01/08 19:46:43 1.731 +++ loncom/interface/loncommon.pm 2012/12/04 18:50:33 1.1100 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # a pile of common routines # -# $Id: loncommon.pm,v 1.731 2009/01/08 19:46:43 raeburn Exp $ +# $Id: loncommon.pm,v 1.1100 2012/12/04 18:50:33 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -70,6 +70,9 @@ use Apache::lonclonecourse(); use LONCAPA qw(:DEFAULT :match); use DateTime::TimeZone; use DateTime::Locale::Catalog; +use Text::Aspell; +use Authen::Captcha; +use Captcha::reCAPTCHA; # ---------------------------------------------- Designs use vars qw(%defaultdesign); @@ -154,6 +157,9 @@ sub ssi_with_retries { # ----------------------------------------------- Filetypes/Languages/Copyright my %language; my %supported_language; +my %supported_codes; +my %latex_language; # For choosing hyphenation in +my %latex_language_bykey; # for choosing hyphenation from metadata my %cprtag; my %scprtag; my %fe; my %fd; my %fm; @@ -186,11 +192,16 @@ BEGIN { while (my $line = <$fh>) { next if ($line=~/^\#/); chomp($line); - my ($key,$two,$country,$three,$enc,$val,$sup)=(split(/\t/,$line)); + my ($key,$code,$country,$three,$enc,$val,$sup,$latex)=(split(/\t/,$line)); $language{$key}=$val.' - '.$enc; if ($sup) { $supported_language{$key}=$sup; + $supported_codes{$key} = $code; } + if ($latex) { + $latex_language_bykey{$key} = $latex; + $latex_language{$code} = $latex; + } } close($fh); } @@ -406,9 +417,10 @@ sub studentbrowser_javascript { || ($env{'request.role'}=~/^(au|dc|su)/) ) { return ''; } return (<<'ENDSTDBRW'); - ENDSTDBRW } +sub resourcebrowser_javascript { + unless ($env{'request.course.id'}) { return ''; } + return (<<'ENDRESBRW'); + +ENDRESBRW +} + sub selectstudent_link { - my ($form,$unameele,$udomele)=@_; + my ($form,$unameele,$udomele,$courseadvonly,$clickerid)=@_; + my $callargs = "'".&Apache::lonhtmlcommon::entity_encode($form)."','". + &Apache::lonhtmlcommon::entity_encode($unameele)."','". + &Apache::lonhtmlcommon::entity_encode($udomele)."'"; if ($env{'request.course.id'}) { if (!&Apache::lonnet::allowed('srm',$env{'request.course.id'}) && !&Apache::lonnet::allowed('srm',$env{'request.course.id'}. '/'.$env{'request.course.sec'})) { return ''; } - return "".&mt('Select User').""; + $callargs.=",'".&Apache::lonhtmlcommon::entity_encode($clickerid)."'"; + if ($courseadvonly) { + $callargs .= ",'',1,1"; + } + return ''. + ''. + &mt('Select User').''; } if ($env{'request.role'}=~/^(au|dc|su)/) { - return "".&mt('Select User').""; + $callargs .= ",'',1"; + return ''. + ''. + &mt('Select User').''; } return ''; } +sub selectresource_link { + my ($form,$reslink,$arg)=@_; + + my $callargs = "'".&Apache::lonhtmlcommon::entity_encode($form)."','". + &Apache::lonhtmlcommon::entity_encode($reslink)."'"; + unless ($env{'request.course.id'}) { return $arg; } + return ''. + ''. + $arg.''; +} + + + sub authorbrowser_javascript { return <<"ENDAUTHORBRW"; - ENDAUTHORBRW } sub coursebrowser_javascript { - my ($domainfilter,$sec_element,$formname)=@_; - my $crs_or_grp_alert = &mt('Please select the type of LON-CAPA entity - Course or Group - for which you wish to add/modify a user role'); - my $output = ' -'; + return $output; +} + +sub javascript_index_functions { + return <<"ENDJS"; + +function getFormIdByName(formname) { + for (var i=0;i -1) { + var domid = getIndexByName(formid,udom); + if (domid > -1) { + if (document.forms[formid].elements[domid].type == 'select-one') { + userdom=document.forms[formid].elements[domid].options[document.forms[formid].elements[domid].selectedIndex].value; + } + if (document.forms[formid].elements[domid].type == 'hidden') { + userdom=document.forms[formid].elements[domid].value; } } - return -1; } + return userdom; +} + +ENDJS + +} - function getIndexByName(formid,item) { - for (var i=0;i +// >> 0; + if (len === 0) { + return -1; + } + var n = 0; + if (arguments.length > 0) { + n = Number(arguments[1]); + if (n !== n) { // shortcut for verifying if it is NaN + n = 0; + } else if (n !== 0 && n !== (1 / 0) && n !== -(1 / 0)) { + n = (n > 0 || -1) * Math.floor(Math.abs(n)); + } + } + if (n >= len) { + return -1; + } + var k = n >= 0 ? n : Math.max(len - Math.abs(n), 0); + for (; k < len; k++) { + if (k in t && t[k] === searchElement) { + return k; } } return -1; } -ENDSTDBRW - if ($sec_element ne '') { - $output .= &setsec_javascript($sec_element,$formname); +} + +// ]]> + + +ENDJS + +} + +sub userbrowser_javascript { + my $id_functions = &javascript_index_functions(); + return <<"ENDUSERBRW"; + +function openuserbrowser(formname,uname,udom,ulast,ufirst,uemail,hideudom,crsdom,caller) { + var url = '/adm/pickuser?'; + var userdom = getDomainFromSelectbox(formname,udom); + if (userdom != null) { + if (userdom != '') { + url += 'srchdom='+userdom+'&'; + } } - $output .= ' -'; - return $output; + url += 'form=' + formname + '&unameelement='+uname+ + '&udomelement='+udom+ + '&ulastelement='+ulast+ + '&ufirstelement='+ufirst+ + '&uemailelement='+uemail+ + '&hideudomelement='+hideudom+ + '&coursedom='+crsdom; + if ((caller != null) && (caller != undefined)) { + url += '&caller='+caller; + } + var title = 'User_Browser'; + var options = 'scrollbars=1,resizable=1,menubar=0'; + options += ',width=700,height=600'; + var stdeditbrowser = open(url,title,options,'1'); + stdeditbrowser.focus(); +} + +function fix_domain (formname,udom,origdom,uname) { + var formid = getFormIdByName(formname); + if (formid > -1) { + var unameid = getIndexByName(formid,uname); + var domid = getIndexByName(formid,udom); + var hidedomid = getIndexByName(formid,origdom); + if (hidedomid > -1) { + var fixeddom = document.forms[formid].elements[hidedomid].value; + var unameval = document.forms[formid].elements[unameid].value; + if ((fixeddom != '') && (fixeddom != undefined) && (fixeddom != null) && (unameval != '') && (unameval != undefined) && (unameval != null)) { + if (domid > -1) { + var slct = document.forms[formid].elements[domid]; + if (slct.type == 'select-one') { + var i; + for (i=0;i".&mt('Select Course').""; + my ($form,$unameele,$udomele,$desc,$extra_element,$multflag,$selecttype, + $typeelement) = @_; + my $type = $selecttype; + my $linktext = &mt('Select Course'); + if ($selecttype eq 'Community') { + $linktext = &mt('Select Community'); + } elsif ($selecttype eq 'Course/Community') { + $linktext = &mt('Select Course/Community'); + $type = ''; + } elsif ($selecttype eq 'Select') { + $linktext = &mt('Select'); + $type = ''; + } + return '' + ."".$linktext.'' + .''; } sub selectauthor_link { @@ -612,15 +877,27 @@ sub selectauthor_link { &mt('Select Author').''; } +sub selectuser_link { + my ($form,$unameelem,$domelem,$lastelem,$firstelem,$emailelem,$hdomelem, + $coursedom,$linktext,$caller) = @_; + return ''.$linktext.''; +} + sub check_uncheck_jscript { my $jscript = <<"ENDSCRT"; function checkAll(field) { if (field.length > 0) { for (i = 0; i < field.length; i++) { - field[i].checked = true ; + if (!field[i].disabled) { + field[i].checked = true; + } } } else { - field.checked = true + if (!field.disabled) { + field.checked = true; + } } } @@ -710,6 +987,48 @@ sub select_datelocale { return $output; } +sub select_language { + my ($name,$selected,$includeempty) = @_; + my %langchoices; + if ($includeempty) { + %langchoices = ('' => 'No language preference'); + } + foreach my $id (&languageids()) { + my $code = &supportedlanguagecode($id); + if ($code) { + $langchoices{$code} = &plainlanguagedescription($id); + } + } + return &select_form($selected,$name,\%langchoices); +} + +=pod + + +=item * &list_languages() + +Returns an array reference that is suitable for use in language prompters. +Each array element is itself a two element array. The first element +is the language code. The second element a descsriptiuon of the +language itself. This is suitable for use in e.g. +&Apache::edit::select_arg (once dereferenced that is). + +=cut + +sub list_languages { + my @lang_choices; + + foreach my $id (&languageids()) { + my $code = &supportedlanguagecode($id); + if ($code) { + my $selector = $supported_codes{$id}; + my $description = &plainlanguagedescription($id); + push (@lang_choices, [$selector, $description]); + } + } + return \@lang_choices; +} + =pod =item * &linked_select_forms(...) @@ -796,7 +1115,8 @@ sub linked_select_forms { my $first = "document.$formname.$firstselectname"; # output the javascript to do the changing my $result = ''; - $result.=" END # output the initial values for the selection lists @@ -877,7 +1198,7 @@ END =pod -=item * &help_open_topic($topic,$text,$stayOnPage,$width,$height) +=item * &help_open_topic($topic,$text,$stayOnPage,$width,$height,$imgid) Returns a string corresponding to an HTML link to the given help $topic, where $topic corresponds to the name of a .tex file in @@ -895,18 +1216,19 @@ a new window using Javascript. (Default $width and $height are optional numerical parameters that will override the width and height of the popped up window, which may -be useful for certain help topics with big pictures included. +be useful for certain help topics with big pictures included. + +$imgid is the id of the img tag used for the help icon. This may be +used in a javascript call to switch the image src. See +lonhtmlcommon::htmlareaselectactive() for an example. =cut sub help_open_topic { - my ($topic, $text, $stayOnPage, $width, $height) = @_; + my ($topic, $text, $stayOnPage, $width, $height, $imgid) = @_; $text = "" if (not defined $text); $stayOnPage = 0 if (not defined $stayOnPage); - if ($env{'browser.interface'} eq 'textual') { - $stayOnPage=1; - } - $width = 350 if (not defined $width); + $width = 500 if (not defined $width); $height = 400 if (not defined $height); my $filename = $topic; $filename =~ s/ /_/g; @@ -917,25 +1239,34 @@ sub help_open_topic { $topic=~s/\W/\_/g; if (!$stayOnPage) { - $link = "javascript:void(open('/adm/help/${filename}.hlp', 'Help_for_$topic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))"; + $link = "javascript:openMyModal('/adm/help/${filename}.hlp',$width,$height,'yes');"; + } elsif ($stayOnPage eq 'popup') { + $link = "javascript:void(open('/adm/help/${filename}.hlp', 'Help_for_$topic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))"; } else { $link = "/adm/help/${filename}.hlp"; } # Add the text - if ($text ne "") { - $template .= - "". - "
$text"; + if ($text ne "") { + $template.='' + .'' + .$text.''; } - # Add the graphic + # (Always) Add the graphic my $title = &mt('Online Help'); my $helpicon=&lonhttpdurl("/adm/help/help.png"); - $template .= <<"ENDTEMPLATE"; - (Help: $topic) -ENDTEMPLATE - if ($text ne '') { $template.='
' }; + if ($imgid ne '') { + $imgid = ' id="'.$imgid.'"'; + } + $template.=' ' + .''.&mt('Help: [_1]',$topic).''; + if ($text ne "") { + $template.=''; + } return $template; } @@ -943,31 +1274,33 @@ ENDTEMPLATE # This is a quicky function for Latex cheatsheet editing, since it # appears in at least four places sub helpLatexCheatsheet { - my $other = shift; + my ($topic,$text,$not_author,$stayOnPage) = @_; + my $out; my $addOther = ''; - if ($other) { - $addOther = Apache::loncommon::help_open_topic($other, shift, - undef, undef, 600) . - ''; - } - return '
'. - $addOther . - &Apache::loncommon::help_open_topic("Greek_Symbols",&mt('Greek Symbols'), - undef,undef,600) - .''. - &Apache::loncommon::help_open_topic("Other_Symbols",&mt('Other Symbols'), - undef,undef,600) - .''. - &Apache::loncommon::help_open_topic("Authoring_Output_Tags",&mt('Output Tags'), - undef,undef,600) - .'
'; + if ($topic) { + $addOther = ''.&help_open_topic($topic,&mt($text),$stayOnPage, undef, 600).' '; + } + $out = '' # Start cheatsheet + .$addOther + .'' + .&help_open_topic('Greek_Symbols',&mt('Greek Symbols'),$stayOnPage,undef,600) + .' ' + .&help_open_topic('Other_Symbols',&mt('Other Symbols'),$stayOnPage,undef,600) + .''; + unless ($not_author) { + $out .= ' ' + .&help_open_topic('Authoring_Output_Tags',&mt('Output Tags'),$stayOnPage,undef,600) + .''; + } + $out .= ''; # End cheatsheet + return $out; } sub general_help { my $helptopic='Student_Intro'; if ($env{'request.role'}=~/^(ca|au)/) { $helptopic='Authoring_Intro'; - } elsif ($env{'request.role'}=~/^cc/) { + } elsif ($env{'request.role'}=~/^(cc|co)/) { $helptopic='Course_Coordination_Intro'; } elsif ($env{'request.role'}=~/^dc/) { $helptopic='Domain_Coordination_Intro'; @@ -987,7 +1320,9 @@ sub update_help_link { my $banner_link = "/adm/helpmenu?page=banner&topic=$topic&component_help=$component_help&faq=$faq&bug=$bug&origurl=$origurl&stamp=$timestamp&stayonpage=$stayOnPage"; my $output .= <<"ENDOUTPUT"; ENDOUTPUT return $output; @@ -997,13 +1332,7 @@ ENDOUTPUT sub help_open_menu { my ($topic,$component_help,$faq,$bug,$stayOnPage,$width,$height,$text) = @_; - $stayOnPage = 0 if (not defined $stayOnPage); - # only use pop-up help (stayOnPage == 0) - # if environment.remote is on (using remote control UI) - if ($env{'browser.interface'} eq 'textual' || - $env{'environment.remote'} eq 'off' ) { - $stayOnPage=1; - } + $stayOnPage = 1; my $output; if ($component_help) { if (!$text) { @@ -1024,9 +1353,8 @@ sub help_open_menu { sub top_nav_help { my ($text) = @_; $text = &mt($text); - my $stay_on_page = - ($env{'browser.interface'} eq 'textual' || - $env{'environment.remote'} eq 'off' ); + my $stay_on_page = 1; + my $link = ($stay_on_page) ? "javascript:helpMenu('display')" : "javascript:helpMenu('open')"; my $banner_link = &update_help_link(undef,undef,undef,undef,$stay_on_page); @@ -1041,11 +1369,7 @@ END sub help_menu_js { my ($text) = @_; - - my $stayOnPage = - ($env{'browser.interface'} eq 'textual' || - $env{'environment.remote'} eq 'off' ); - + my $stayOnPage = 1; my $width = 620; my $height = 600; my $helptopic=&general_help(); @@ -1064,8 +1388,8 @@ sub help_menu_js { my $template .= <<"ENDTEMPLATE"; ENDTEMPLATE return $template; @@ -1102,11 +1426,7 @@ sub help_open_bug { unless ($env{'user.adv'}) { return ''; } unless ($Apache::lonnet::perlvar{'BugzillaHost'}) { return ''; } $text = "" if (not defined $text); - $stayOnPage = 0 if (not defined $stayOnPage); - if ($env{'browser.interface'} eq 'textual' || - $env{'environment.remote'} eq 'off' ) { $stayOnPage=1; - } $width = 600 if (not defined $width); $height = 600 if (not defined $height); @@ -1147,11 +1467,7 @@ sub help_open_faq { unless ($env{'user.adv'}) { return ''; } unless ($Apache::lonnet::perlvar{'FAQHost'}) { return ''; } $text = "" if (not defined $text); - $stayOnPage = 0 if (not defined $stayOnPage); - if ($env{'browser.interface'} eq 'textual' || - $env{'environment.remote'} eq 'off' ) { $stayOnPage=1; - } $width = 350 if (not defined $width); $height = 400 if (not defined $height); @@ -1359,6 +1675,7 @@ sub resize_textarea_js { my $geometry = &viewport_geometry_js(); return <<"RESIZE"; RESIZE @@ -1466,6 +1784,7 @@ Inputs: $workbook Returns: $format, a hash reference. + =cut ############################################################### @@ -1517,14 +1836,17 @@ sub create_workbook { my $workbook = Spreadsheet::WriteExcel->new('/home/httpd'.$filename); if (! defined($workbook)) { $r->log_error("Error creating excel spreadsheet $filename: $!"); - $r->print('

'.&mt("Unable to create new Excel file. ". - "This error has been logged. ". - "Please alert your LON-CAPA administrator"). - '

'); + $r->print( + '

' + .&mt('Problems occurred in creating the new Excel file.') + .' '.&mt('This error has been logged.') + .' '.&mt('Please alert your LON-CAPA administrator.') + .'

' + ); return (undef); } # - $workbook->set_tempdir('/home/httpd/perl/tmp'); + $workbook->set_tempdir(LONCAPA::tempdir()); # my $format = &Apache::loncommon::define_excel_formats($workbook); return ($workbook,$filename,$format); @@ -1560,9 +1882,13 @@ sub create_text_file { $fh = Apache::File->new('>/home/httpd'.$filename); if (! defined($fh)) { $r->log_error("Couldn't open $filename for output $!"); - $r->print(&mt('Problems occurred in creating the output file. ' - .'This error has been logged. ' - .'Please alert your LON-CAPA administrator.')); + $r->print( + '

' + .&mt('Problems occurred in creating the output file.') + .' '.&mt('This error has been logged.') + .' '.&mt('Please alert your LON-CAPA administrator.') + .'

' + ); } return ($fh,$filename) } @@ -1591,7 +1917,7 @@ sub domain_select { return &multiple_select_form($name,$value,4,\%domains); } else { $domains{'select_form_order'} = [sort {lc($a) cmp lc($b) } (keys(%domains))]; - return &select_form($name,$value,%domains); + return &select_form($name,$value,\%domains); } } @@ -1629,7 +1955,7 @@ sub multiple_select_form { $size = scalar(keys(%$hash)); } } - $output.="\n'; my @order; if (ref($order) eq 'ARRAY') { @order = @{$order}; @@ -1653,29 +1979,36 @@ sub multiple_select_form { =pod -=item * &select_form($defdom,$name,%hash) +=item * &select_form($defdom,$name,$hashref,$onchange) Returns a string containing a \n"; + my ($def,$name,$hashref,$onchange) = @_; + return unless (ref($hashref) eq 'HASH'); + if ($onchange) { + $onchange = ' onchange="'.$onchange.'"'; + } + my $selectform = ""; return $selectform; @@ -1684,19 +2017,112 @@ sub select_form { # For display filters sub display_filter { + my ($context) = @_; if (!$env{'form.show'}) { $env{'form.show'}=10; } if (!$env{'form.displayfilter'}) { $env{'form.displayfilter'}='currentfolder'; } - return '
'; + next; } else { - $output .= '

'.&mt('Uploaded [_1]',''. - $path.$fname.'').'

'; + $output .= &mt('Uploaded [_1]',''. + $path.$fname.'').'
'; } } else { # Save the file @@ -7692,12 +10088,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); } } @@ -7705,30 +10101,244 @@ 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(). + ''. + ''.$env{'form.embedded_ref_'.$i}. + ''. + ''. + ''. + ''.$env{'form.embedded_orig_'.$i}. + ''. + &end_data_table_row(); + } + } + } else { + $modifyform = $pathchgtable; + if (($actionurl eq '/adm/upload') || ($actionurl eq '/adm/testbank')) { + $hiddenstate .= ''; + } elsif (($actionurl eq '/adm/portfolio') || ($actionurl eq '/adm/coursegrp_portfolio')) { + $hiddenstate .= ''; + } + } + 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". + '
  1. '.&mt('For consistency between the reference(s) and the location of the corresponding stored file within LON-CAPA.').'
    2. '."\n". + '
  2. '.&mt('To change absolute paths to relative paths, or replace directory traversal via "../" within the original reference.').'
    3. '."\n". + '

'."\n".'

'. + &mt('LON-CAPA can make the required changes to your HTML file.').'

'."\n". + '
'. + &start_data_table()."\n". + &start_data_table_header_row(). + ''.&mt('Change?').''. + ''.&mt('Current reference').''. + ''.&mt('Required reference').''. + &end_data_table_header_row()."\n". + $modifyform. + &end_data_table().'
'."\n".$hiddenstate. + ''. + '
'."\n"; + } + return; +} + +sub modify_html_refs { + my ($context,$dirpath,$uname,$udom,$dir_root) = @_; + 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"; + } 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')) { + 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; + } + 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 ++; + } + } + } + if ($count || $codebasecount) { + my $saveresult; + 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.'').'

'; + } else { + $output = '

'. + &mt('Error: update failed for: [_1].', + ''. + $container.'').'

'; + } + } 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.'').'

'; + } + } + } + } 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 { @@ -7750,22 +10360,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); + } + } + } } } } @@ -7783,15 +10444,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.'
'; + } + } + $output .= '
'."\n"; + my $duplicates; + my $num = 0; + if (ref($dirlist) eq 'ARRAY') { + foreach my $item (@{$dirlist}) { + if (ref($item) eq 'ARRAY') { + if (exists($toplevel{$item->[0]})) { + $duplicates .= + &start_data_table_row(). + ''. + ' '. + ''."\n". + ''.$item->[0].''; + if ($item->[2]) { + $duplicates .= ''.&mt('Directory').''; + } else { + $duplicates .= ''.&mt('File').''; + } + $duplicates .= ''.$item->[3].''. + ''. + &Apache::lonlocal::locallocaltime($item->[4]). + ''. + &end_data_table_row(); + $num ++; + } + } + } + } + my $itemcount; + if (@paths > 0) { + $itemcount = scalar(@paths); + } else { + $itemcount = 1; + } + if ($is_camtasia) { + $output .= $lt{'auto'}.'
'. + ''.$lt{'proa'}.' 
'. + '
'. + &Apache::lonhtmlcommon::start_pick_box(). + &Apache::lonhtmlcommon::row_title($lt{'fold'}). + ''."\n". + &Apache::lonhtmlcommon::row_closure(). + &Apache::lonhtmlcommon::row_title($lt{'movi'}). + ''."\n". + &Apache::lonhtmlcommon::row_closure(1). + &Apache::lonhtmlcommon::end_pick_box(). + '
'; + } + $output .= + ''. + ''. + "\n"; + if ($duplicates ne '') { + $output .= '

'. + &mt('Warning: decompression of the archive will overwrite the following items which already exist:').'
'. + &start_data_table(). + &start_data_table_header_row(). + ''.&mt('Overwrite?').''. + ''.&mt('Name').''. + ''.&mt('Type').''. + ''.&mt('Size').''. + ''.&mt('Last modified').''. + &end_data_table_header_row(). + $duplicates. + &end_data_table(). + '

'; + } + $output .= ''."\n"; + if (ref($hiddenelements) eq 'HASH') { + foreach my $hidden (sort(keys(%{$hiddenelements}))) { + $output .= ''."\n"; + } + } + $output .= <<"END"; +
+ +
+$noextract +END + return $output; +} + +sub decompression_utility { + my ($program) = @_; + my @utilities = ('tar','gunzip','bunzip2','unzip'); + my $location; + if (grep(/^\Q$program\E$/,@utilities)) { + foreach my $dir ('/bin/','/usr/bin/','/usr/local/bin/','/sbin/', + '/usr/sbin/') { + if (-x $dir.$program) { + $location = $dir.$program; + last; + } + } + } + return $location; +} + +sub list_archive_contents { + my ($file,$pathsref) = @_; + my (@cmd,$output); + my $needsregexp; + if ($file =~ /\.zip$/) { + @cmd = (&decompression_utility('unzip'),"-l"); + $needsregexp = 1; + } elsif (($file =~ m/\.tar\.gz$/) || + ($file =~ /\.tgz$/)) { + @cmd = (&decompression_utility('tar'),"-ztf"); + } elsif ($file =~ /\.tar\.bz2$/) { + @cmd = (&decompression_utility('tar'),"-jtf"); + } elsif ($file =~ m|\.tar$|) { + @cmd = (&decompression_utility('tar'),"-tf"); + } + if (@cmd) { + undef($!); + undef($@); + if (open(my $fh,"-|", @cmd, $file)) { + while (my $line = <$fh>) { + $output .= $line; + chomp($line); + my $item; + if ($needsregexp) { + ($item) = ($line =~ /^\s*\d+\s+[\d\-]+\s+[\d:]+\s*(.+)$/); + } else { + $item = $line; + } + if ($item ne '') { + unless (grep(/^\Q$item\E$/,@{$pathsref})) { + push(@{$pathsref},$item); + } + } + } + close($fh); + } + } + return $output; +} + +sub decompress_uploaded_file { + my ($file,$dir) = @_; + &Apache::lonnet::appenv({'cgi.file' => $file}); + &Apache::lonnet::appenv({'cgi.dir' => $dir}); + my $result = &Apache::lonnet::ssi_body('/cgi-bin/decompress.pl'); + my ($handle) = ($env{'user.environment'} =~m{/([^/]+)\.id$}); + my $lonidsdir = $Apache::lonnet::perlvar{'lonIDsDir'}; + &Apache::lonnet::transfer_profile_to_env($lonidsdir,$handle,1); + my $decompressed = $env{'cgi.decompressed'}; + &Apache::lonnet::delenv('cgi.file'); + &Apache::lonnet::delenv('cgi.dir'); + &Apache::lonnet::delenv('cgi.decompressed'); + return ($decompressed,$result); +} + +sub process_decompression { + my ($docudom,$docuname,$file,$destination,$dir_root,$hiddenelem) = @_; + my ($dir,$error,$warning,$output); + if ($file !~ /\.(zip|tar|bz2|gz|tar.gz|tar.bz2|tgz)$/) { + $error = &mt('File name not a supported archive file type.'). + '
'.&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.'

'."\n"; + } + if ($warning) { + $output .= '

'.$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().''.$count.''."\n"; + my $offset = 0; + foreach my $action ('display','dependency','discard') { + $offset ++; + if ($action ne 'display') { + $offset ++; + } + $output .= ''. + ''; + if ($action eq 'dependency') { + $output .= ''; + } elsif ($action eq 'display') { + $output .= ''; + } + $output .= ''; + } + $output .= '&').'" />'.(' ' x 2); + for (my $i=0; $i<$depth; $i++) { + $output .= ('' x2)."\n"; + } + if ($is_dir) { + $output .= ' '."\n". + ''."\n"; + } else { + $output .= ''."\n"; + } + $output .= ' '.$name.''."\n". + &end_data_table_row(); + return $output; +} + +sub archive_options_form { + my ($form,$display,$count,$hiddenelem) = @_; + my %lt = &Apache::lonlocal::texthash( + perm => 'Permanently remove archive file?', + hows => 'How should each extracted item be incorporated in the course?', + cont => 'Content actions for all', + addf => 'Add as folder/file', + incd => 'Include as dependency for a displayed file', + disc => 'Discard', + no => 'No', + yes => 'Yes', + save => 'Save', + ); + my $output = <<"END"; +
+

$lt{'perm'}  + +  + + +

+ +
$lt{'hows'} +
+
+ $lt{'cont'} + +    +    +
+
+END + return $output. + &start_data_table()."\n". + $display."\n". + &end_data_table()."\n". + ''. + $hiddenelem. + '
'. + '
'; +} + +sub archive_javascript { + my ($startcount,$numitems,$titles,$children) = @_; + return unless ((ref($titles) eq 'HASH') && (ref($children) eq 'HASH')); + my $maintitle = $env{'form.comment'}; + my $scripttag = < +// 0) { + var startelement = $startcount + ((count-1) * 7); + for (var j=1; j<6; j++) { + if ((j != 2) && (j != 4)) { + var item = startelement + j; + if (form.elements[item].type == 'radio') { + if (form.elements[item].checked) { + containerCheck(form,count,j); + break; + } + } + } + } + } +} + +numitems = $numitems +var titles = new Array(numitems); +var parents = new Array(numitems); +for (var i=0; i $b } (keys(%{$children}))) { + my @contents = split(/:/,$children->{$container}); + for (my $i=0; $i<@contents; $i ++) { + $scripttag .= 'parents['.$container.']['.$i.'] = '.$contents[$i]."\n"; + } + } + + foreach my $key (sort { $a <=> $b } (keys(%{$titles}))) { + $scripttag .= "titles[$key] = '".$titles->{$key}."';\n"; + } + + $scripttag .= < 0) { + dependencyCheck(form,count,offset); + var item = (offset+$startcount)+7*(count-1); + form.elements[item].checked = true; + if(Object.prototype.toString.call(parents[count]) === '[object Array]') { + if (parents[count].length > 0) { + for (var j=0; j 0) { + var chosen = (offset+$startcount)+7*(count-1); + var depitem = $startcount + ((count-1) * 7) + 4; + var currtype = form.elements[depitem].type; + if (form.elements[chosen].value == 'dependency') { + document.getElementById('arc_depon_'+count).style.display='block'; + form.elements[depitem].options.length = 0; + form.elements[depitem].options[0] = new Option('Select','',true,true); + for (var i=1; i<=numitems; i++) { + if (i == count) { + continue; + } + var startelement = $startcount + (i-1) * 7; + for (var j=1; j<6; j++) { + if ((j != 2) && (j!= 4)) { + var item = startelement + j; + if (form.elements[item].type == 'radio') { + if (form.elements[item].checked) { + if (form.elements[item].value == 'display') { + var n = form.elements[depitem].options.length; + form.elements[depitem].options[n] = new Option(titles[i],i,false,false); + } + } + } + } + } + } + } else { + document.getElementById('arc_depon_'+count).style.display='none'; + form.elements[depitem].options.length = 0; + form.elements[depitem].options[0] = new Option('Select','',true,true); + } + titleCheck(form,count,offset); + } +} + +function propagateSelect(form,count,offset) { + if (count > 0) { + var item = (1+offset+$startcount)+7*(count-1); + var picked = form.elements[item].options[form.elements[item].selectedIndex].value; + if (Object.prototype.toString.call(parents[count]) === '[object Array]') { + if (parents[count].length > 0) { + for (var j=0; j 0) { + var item = (offset+$startcount)+7*(count-1); + if (form.elements[item].type == 'radio') { + if (form.elements[item].value == 'dependency') { + if (form.elements[item+1].type == 'select-one') { + for (var i=0; i 0) { + for (var j=0; j 0) { + var chosen = (offset+$startcount)+7*(count-1); + var depitem = $startcount + ((count-1) * 7) + 2; + var currtype = form.elements[depitem].type; + if (form.elements[chosen].value == 'display') { + document.getElementById('arc_title_'+count).style.display='block'; + if ((count==1) && ((parents[count].length > 0) || (numitems == 1))) { + document.getElementById('archive_title_'+count).value=maintitle; + } + } else { + document.getElementById('arc_title_'+count).style.display='none'; + if (currtype == 'text') { + document.getElementById('archive_title_'+count).value=''; + } + } + } + return; +} + +// ]]> + +END + return $scripttag; +} + +sub process_extracted_files { + my ($context,$docudom,$docuname,$destination,$dir_root,$hiddenelem) = @_; + my $numitems = $env{'form.archive_count'}; + return unless ($numitems); + my @ids=&Apache::lonnet::current_machine_ids(); + my ($prefix,$pathtocheck,$dir,$ishome,$error,$warning,%toplevelitems,%is_dir, + %folders,%containers,%mapinner,%prompttofetch); + my $docuhome = &Apache::lonnet::homeserver($docuname,$docudom); + if (grep(/^\Q$docuhome\E$/,@ids)) { + $prefix = &LONCAPA::propath($docudom,$docuname); + $pathtocheck = "$dir_root/$destination"; + $dir = $dir_root; + $ishome = 1; + } else { + $prefix = $Apache::lonnet::perlvar{'lonDocRoot'}; + $pathtocheck = "$dir_root/$docudom/$docuname/$destination"; + $dir = "$dir_root/$docudom/$docuname"; + } + my $currdir = "$dir_root/$destination"; + (my $docstype,$mapinner{'0'}) = ($destination =~ m{^(docs|supplemental)/(\w+)/}); + if ($env{'form.folderpath'}) { + my @items = split('&',$env{'form.folderpath'}); + $folders{'0'} = $items[-2]; + if ($env{'form.folderpath'} =~ /\:1$/) { + $containers{'0'}='page'; + } else { + $containers{'0'}='sequence'; + } + } + my @archdirs = &get_env_multiple('form.archive_directory'); + if ($numitems) { + for (my $i=1; $i<=$numitems; $i++) { + my $path = $env{'form.archive_content_'.$i}; + if ($path =~ m{^\Q$pathtocheck\E/([^/]+)$}) { + my $item = $1; + $toplevelitems{$item} = $i; + if (grep(/^\Q$i\E$/,@archdirs)) { + $is_dir{$item} = 1; + } + } + } + } + my ($output,%children,%parent,%titles,%dirorder,$result); + if (keys(%toplevelitems) > 0) { + my @contents = sort(keys(%toplevelitems)); + (my $count,undef) = &get_extracted($docudom,$docuname,$currdir,\%is_dir,\%children, + \%parent,\@contents,\%dirorder,\%titles); + } + my (%referrer,%orphaned,%todelete,%todeletedir,%newdest,%newseqid); + if ($numitems) { + for (my $i=1; $i<=$numitems; $i++) { + next if ($env{'form.archive_'.$i} eq 'dependency'); + my $path = $env{'form.archive_content_'.$i}; + if ($path =~ /^\Q$pathtocheck\E/) { + if ($env{'form.archive_'.$i} eq 'discard') { + if ($prefix ne '' && $path ne '') { + if (-e $prefix.$path) { + if ((@archdirs > 0) && + (grep(/^\Q$i\E$/,@archdirs))) { + $todeletedir{$prefix.$path} = 1; + } else { + $todelete{$prefix.$path} = 1; + } + } + } + } elsif ($env{'form.archive_'.$i} eq 'display') { + my ($docstitle,$title,$url,$outer); + ($title) = ($path =~ m{/([^/]+)$}); + $docstitle = $env{'form.archive_title_'.$i}; + if ($docstitle eq '') { + $docstitle = $title; + } + $outer = 0; + if (ref($dirorder{$i}) eq 'ARRAY') { + if (@{$dirorder{$i}} > 0) { + foreach my $item (reverse(@{$dirorder{$i}})) { + if ($env{'form.archive_'.$item} eq 'display') { + $outer = $item; + last; + } + } + } + } + my ($errtext,$fatal) = + &LONCAPA::map::mapread('/uploaded/'.$docudom.'/'.$docuname. + '/'.$folders{$outer}.'.'. + $containers{$outer}); + next if ($fatal); + if ((@archdirs > 0) && (grep(/^\Q$i\E$/,@archdirs))) { + if ($context eq 'coursedocs') { + $mapinner{$i} = time; + $folders{$i} = 'default_'.$mapinner{$i}; + $containers{$i} = 'sequence'; + my $url = '/uploaded/'.$docudom.'/'.$docuname.'/'. + $folders{$i}.'.'.$containers{$i}; + my $newidx = &LONCAPA::map::getresidx(); + $LONCAPA::map::resources[$newidx]= + $docstitle.':'.$url.':false:normal:res'; + push(@LONCAPA::map::order,$newidx); + my ($outtext,$errtext) = + &LONCAPA::map::storemap('/uploaded/'.$docudom.'/'. + $docuname.'/'.$folders{$outer}. + '.'.$containers{$outer},1,1); + $newseqid{$i} = $newidx; + unless ($errtext) { + $result .= '
  • '.&mt('Folder: [_1] added to course',$docstitle).'
    • '."\n"; + } + } + } else { + if ($context eq 'coursedocs') { + my $newidx=&LONCAPA::map::getresidx(); + my $url = '/uploaded/'.$docudom.'/'.$docuname.'/'. + $docstype.'/'.$mapinner{$outer}.'/'.$newidx.'/'. + $title; + if (!-e "$prefix$dir/$docstype/$mapinner{$outer}") { + mkdir("$prefix$dir/$docstype/$mapinner{$outer}",0755); + } + if (!-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx") { + mkdir("$prefix$dir/$docstype/$mapinner{$outer}/$newidx"); + } + if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx") { + system("mv $prefix$path $prefix$dir/$docstype/$mapinner{$outer}/$newidx/$title"); + $newdest{$i} = "$prefix$dir/$docstype/$mapinner{$outer}/$newidx"; + unless ($ishome) { + my $fetch = "$newdest{$i}/$title"; + $fetch =~ s/^\Q$prefix$dir\E//; + $prompttofetch{$fetch} = 1; + } + } + $LONCAPA::map::resources[$newidx]= + $docstitle.':'.$url.':false:normal:res'; + push(@LONCAPA::map::order, $newidx); + my ($outtext,$errtext)= + &LONCAPA::map::storemap('/uploaded/'.$docudom.'/'. + $docuname.'/'.$folders{$outer}. + '.'.$containers{$outer},1,1); + unless ($errtext) { + if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx/$title") { + $result .= '
  • '.&mt('File: [_1] added to course',$docstitle).'
    • '."\n"; + } + } + } + } + } + } else { + $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',$path).'
    '; + } + } + 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 .= '
  • '.&mt('[_1] included as a dependency',$showpath).'
    • '."\n"; + } + unless ($ishome) { + my $fetch = "$fullpath/$title"; + $fetch =~ s/^\Q$prefix$dir\E//; + $prompttofetch{$fetch} = 1; + } + } + } + } elsif ($env{'form.archive_'.$referrer{$i}} eq 'discard') { + $warning .= &mt('[_1] is a dependency of [_2], which was discarded.', + $path,$env{'form.archive_content_'.$referrer{$i}}).'
    '; + } + } 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". + '
    '; + } + unless ($ishome) { + my $replicationfail; + foreach my $item (keys(%prompttofetch)) { + my $fetchresult= &Apache::lonnet::reply('fetchuserfile:'.$item,$docuhome); + unless ($fetchresult eq 'ok') { + $replicationfail .= '
  • '.$item.'
    • '."\n"; + } + } + if ($replicationfail) { + $output .= '

    '. + &mt('Course home server failed to retrieve:').'

      '. + $replicationfail. + '

    '; + } + } + } else { + $warning = &mt('No items found in archive.'); + } + if ($error) { + $output .= '

    '.&mt('Not extracted.').'
    '. + $error.'

    '."\n"; + } + if ($warning) { + $output .= '

    '.$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() + +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 @@ -8026,7 +12000,7 @@ sub csv_print_samples { $r->print(&mt('Samples').'
    '.&start_data_table(). &start_data_table_header_row()); foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) { - $r->print(''.&mt('Column [_1]',($sample+1)).''); } + $r->print(''.&mt('Column [_1]',($sample+1)).''); } $r->print(&end_data_table_header_row()); foreach my $hash (@$samples) { $r->print(&start_data_table_row()); @@ -8070,7 +12044,7 @@ sub csv_print_select_table { my ($value,$display,$defaultcol)=@{ $array_ref }; $r->print(&start_data_table_row().''.$display.''); - $r->print(''); $r->print(''); foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) { @@ -8724,9 +12698,11 @@ sub restore_settings { =item * &build_recipient_list() -Build recipient lists for three types of e-mail: -(a) Error Reports, (b) Package Updates, (c) Help requests, generated by -lonerrorhandler.pm, CHECKRPMS and lonsupportreq.pm respectively. +Build recipient lists for five types of e-mail: +(a) Error Reports, (b) Package Updates, (c) lonstatus warnings/errors +(d) Help requests, (e) Course requests needing approval, generated by +lonerrorhandler.pm, CHECKRPMS, loncron, lonsupportreq.pm and +loncoursequeueadmin.pm respectively. Inputs: defmail (scalar - email address of default recipient), @@ -8750,17 +12726,21 @@ sub build_recipient_list { my %domconfig = &Apache::lonnet::get_dom('configuration',['contacts'],$defdom); if (ref($domconfig{'contacts'}) eq 'HASH') { - if (ref($domconfig{'contacts'}{$mailing}) eq 'HASH') { - my @contacts = ('adminemail','supportemail'); - foreach my $item (@contacts) { - if ($domconfig{'contacts'}{$mailing}{$item}) { - my $addr = $domconfig{'contacts'}{$item}; - if (!grep(/^\Q$addr\E$/,@recipients)) { - push(@recipients,$addr); + if (exists($domconfig{'contacts'}{$mailing})) { + if (ref($domconfig{'contacts'}{$mailing}) eq 'HASH') { + my @contacts = ('adminemail','supportemail'); + foreach my $item (@contacts) { + if ($domconfig{'contacts'}{$mailing}{$item}) { + my $addr = $domconfig{'contacts'}{$item}; + if (!grep(/^\Q$addr\E$/,@recipients)) { + push(@recipients,$addr); + } } + $otheremails = $domconfig{'contacts'}{$mailing}{'others'}; } - $otheremails = $domconfig{'contacts'}{$mailing}{'others'}; } + } elsif ($origmail ne '') { + push(@recipients,$origmail); } } elsif ($origmail ne '') { push(@recipients,$origmail); @@ -8892,6 +12872,8 @@ sub extract_categories { my $trailstr; if ($name eq 'instcode') { $trailstr = &mt('Official courses (with institutional codes)'); + } elsif ($name eq 'communities') { + $trailstr = &mt('Communities'); } else { $trailstr = $name; } @@ -9004,12 +12986,14 @@ cathash - reference to hash of categorie currcat - scalar with an & separated list of categories assigned to a course. +type - scalar contains course type (Course or Community). + Returns: $output (markup to be displayed) =cut sub assign_categories_table { - my ($cathash,$currcat) = @_; + my ($cathash,$currcat,$type) = @_; my $output; if (ref($cathash) eq 'HASH') { my (@cats,@trails,%allitems,%idx,@jsarray,@path,$maxdepth); @@ -9018,34 +13002,47 @@ sub assign_categories_table { if (@cats > 0) { my $itemcount = 0; if (ref($cats[0]) eq 'ARRAY') { - $output = &Apache::loncommon::start_data_table(); my @currcategories; if ($currcat ne '') { @currcategories = split('&',$currcat); } + my $table; for (my $i=0; $i<@{$cats[0]}; $i++) { my $parent = $cats[0][$i]; - my $css_class = $itemcount%2?' class="LC_odd_row"':''; next if ($parent eq 'instcode'); + if ($type eq 'Community') { + next unless ($parent eq 'communities'); + } else { + next if ($parent eq 'communities'); + } + my $css_class = $itemcount%2?' class="LC_odd_row"':''; my $item = &escape($parent).'::0'; my $checked = ''; if (@currcategories > 0) { if (grep(/^\Q$item\E$/,@currcategories)) { - $checked = ' checked="checked" '; + $checked = ' checked="checked"'; } } - $output .= ''. - ''.$parent.''. - ''; + my $parent_title = $parent; + if ($parent eq 'communities') { + $parent_title = &mt('Communities'); + } + $table .= ''. + ''.$parent_title.''. + ''; my $depth = 1; push(@path,$parent); - $output .= &assign_category_rows($itemcount,\@cats,$depth,$parent,\@path,\@currcategories); + $table .= &assign_category_rows($itemcount,\@cats,$depth,$parent,\@path,\@currcategories); pop(@path); - $output .= ''; + $table .= ''; $itemcount ++; } - $output .= &Apache::loncommon::end_data_table(); + if ($itemcount) { + $output = &Apache::loncommon::start_data_table(). + $table. + &Apache::loncommon::end_data_table(); + } } } } @@ -9097,7 +13094,7 @@ sub assign_category_rows { if (ref($currcategories) eq 'ARRAY') { if (@{$currcategories} > 0) { if (grep(/^\Q$item\E$/,@{$currcategories})) { - $checked = ' checked="checked" '; + $checked = ' checked="checked"'; } } } @@ -9290,12 +13287,26 @@ sub check_clone { my $clonehome=&Apache::lonnet::homeserver($clonecrsunum,$clonecrsudom); my $clonemsg; my $can_clone = 0; - + my $lctype = lc($args->{'crstype'}); + if ($lctype ne 'community') { + $lctype = 'course'; + } if ($clonehome eq 'no_host') { - $clonemsg = &mt('No new course created.').$linefeed.&mt('A new course could not be cloned from the specified original - [_1] - because it is a non-existent course.',$args->{'clonecourse'}.':'.$args->{'clonedomain'}); + if ($args->{'crstype'} eq 'Community') { + $clonemsg = &mt('No new community created.').$linefeed.&mt('A new community could not be cloned from the specified original - [_1] - because it is a non-existent community.',$args->{'clonecourse'}.':'.$args->{'clonedomain'}); + } else { + $clonemsg = &mt('No new course created.').$linefeed.&mt('A new course could not be cloned from the specified original - [_1] - because it is a non-existent course.',$args->{'clonecourse'}.':'.$args->{'clonedomain'}); + } } else { my %clonedesc = &Apache::lonnet::coursedescription($cloneid,{'one_time' => 1}); - if ($env{'request.role.domain'} eq $args->{'clonedomain'}) { + if ($args->{'crstype'} eq 'Community') { + if ($clonedesc{'type'} ne 'Community') { + $clonemsg = &mt('No new community created.').$linefeed.&mt('A new community could not be cloned from the specified original - [_1] - because it is a course not a community.',$args->{'clonecourse'}.':'.$args->{'clonedomain'}); + return ($can_clone, $clonemsg, $cloneid, $clonehome); + } + } + if (($env{'request.role.domain'} eq $args->{'clonedomain'}) && + (&Apache::lonnet::allowed('ccc',$env{'request.role.domain'}))) { $can_clone = 1; } else { my %clonehash = &Apache::lonnet::get('environment',['cloners'], @@ -9306,15 +13317,25 @@ sub check_clone { } elsif (grep(/^\*\:\Q$args->{'ccdomain'}\E$/,@cloners)) { $can_clone = 1; } else { + my $ccrole = 'cc'; + if ($args->{'crstype'} eq 'Community') { + $ccrole = 'co'; + } my %roleshash = &Apache::lonnet::get_my_roles($args->{'ccuname'}, $args->{'ccdomain'}, - 'userroles',['active'],['cc'], + 'userroles',['active'],[$ccrole], [$args->{'clonedomain'}]); - if (($roleshash{$args->{'clonecourse'}.':'.$args->{'clonedomain'}.':cc'}) || (grep(/^\Q$args->{'ccuname'}\E:\Q$args->{'ccdomain'}\E$/,@cloners))) { - $can_clone = 1; - } else { - $clonemsg = &mt('No new course created.').$linefeed.&mt('The new course could not be cloned from the existing course because the new course owner ([_1]) does not have cloning rights in the existing course ([_2]).',$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'}); + if (($roleshash{$args->{'clonecourse'}.':'.$args->{'clonedomain'}.':'.$ccrole}) || (grep(/^\Q$args->{'ccuname'}\E:\Q$args->{'ccdomain'}\E$/,@cloners))) { + $can_clone = 1; + } elsif (&Apache::lonnet::is_course_owner($args->{'clonedomain'},$args->{'clonecourse'},$args->{'ccuname'},$args->{'ccdomain'})) { + $can_clone = 1; + } else { + if ($args->{'crstype'} eq 'Community') { + $clonemsg = &mt('No new community created.').$linefeed.&mt('The new community could not be cloned from the existing community because the new community owner ([_1]) does not have cloning rights in the existing community ([_2]).',$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'}); + } else { + $clonemsg = &mt('No new course created.').$linefeed.&mt('The new course could not be cloned from the existing course because the new course owner ([_1]) does not have cloning rights in the existing course ([_2]).',$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'}); + } } } } @@ -9323,7 +13344,7 @@ sub check_clone { } sub construct_course { - my ($args,$logmsg,$courseid,$crsudom,$crsunum,$udom,$uname,$context) = @_; + my ($args,$logmsg,$courseid,$crsudom,$crsunum,$udom,$uname,$context,$cnum,$category) = @_; my $outcome; my $linefeed = '
    '."\n"; if ($context eq 'auto') { @@ -9361,18 +13382,27 @@ sub construct_course { $args->{'crscode'}, $args->{'ccuname'}.':'. $args->{'ccdomain'}, - $args->{'crstype'}); + $args->{'crstype'}, + $cnum,$context,$category); # Note: The testing routines depend on this being output; see # Utils::Course. This needs to at least be output as a comment # if anyone ever decides to not show this, and Utils::Course::new # will need to be suitably modified. $outcome .= &mt('New LON-CAPA [_1] ID: [_2]',$crstype,$$courseid).$linefeed; + if ($$courseid =~ /^error:/) { + return (0,$outcome); + } + # # Check if created correctly # ($$crsudom,$$crsunum)= &LONCAPA::split_courseid($$courseid); my $crsuhome=&Apache::lonnet::homeserver($$crsunum,$$crsudom); + if ($crsuhome eq 'no_host') { + $outcome .= &mt('Course creation failed, unrecognized course home server.').$linefeed; + return (0,$outcome); + } $outcome .= &mt('Created on').': '.$crsuhome.$linefeed; # @@ -9391,6 +13421,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 @@ -9637,7 +13671,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'; } @@ -9654,6 +13688,8 @@ sub construct_course { ############################################################ ############################################################ +#SD +# only Community and Course, or anything else? sub course_type { my ($cid) = @_; if (!defined($cid)) { @@ -9670,11 +13706,21 @@ sub group_term { my $crstype = &course_type(); my %names = ( 'Course' => 'group', - 'Group' => 'team', + 'Community' => 'group', ); return $names{$crstype}; } +sub course_types { + my @types = ('official','unofficial','community'); + my %typename = ( + official => 'Official course', + unofficial => 'Unofficial course', + community => 'Community', + ); + return (\@types,\%typename); +} + sub icon { my ($file)=@_; my $curfext = lc((split(/\./,$file))[-1]); @@ -9734,7 +13780,23 @@ sub escape_url { return join('/',@urlslices).'/'.$lastitem; } -# -------------------------------------------------------- Initliaze user login +sub compare_arrays { + my ($arrayref1,$arrayref2) = @_; + my (@difference,%count); + @difference = (); + %count = (); + if ((ref($arrayref1) eq 'ARRAY') && (ref($arrayref2) eq 'ARRAY')) { + foreach my $element (@{$arrayref1}, @{$arrayref2}) { $count{$element}++; } + foreach my $element (keys(%count)) { + if ($count{$element} == 1) { + push(@difference,$element); + } + } + } + return @difference; +} + +# -------------------------------------------------------- Initialize user login sub init_user_environment { my ($r, $username, $domain, $authhost, $form, $args) = @_; my $lonids=$Apache::lonnet::perlvar{'lonIDsDir'}; @@ -9743,7 +13805,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) { @@ -9781,47 +13843,30 @@ 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 my ($httpbrowser,$clientbrowser,$clientversion,$clientmathml, $clientunicode,$clientos) = &decode_user_agent($r); -# -------------------------------------- Any accessibility options to remember? - if (($form->{'interface'}) && ($form->{'remember'} eq 'true')) { - foreach my $option ('imagesuppress','appletsuppress', - 'embedsuppress','fontenhance','blackwhite') { - if ($form->{$option} eq 'true') { - &Apache::lonnet::put('environment',{$option => 'on'}, - $domain,$username); - } else { - &Apache::lonnet::del('environment',[$option], - $domain,$username); - } - } - } # ------------------------------------------------------------- Get environment my %userenv = &Apache::lonnet::dump('environment',$domain,$username); my ($tmp) = keys(%userenv); if ($tmp !~ /^(con_lost|error|no_such_host)/i) { - # default remote control to off - if ($userenv{'remote'} ne 'on') { $userenv{'remote'} = 'off'; } } else { undef(%userenv); } if (($userenv{'interface'}) && (!$form->{'interface'})) { $form->{'interface'}=$userenv{'interface'}; } - $env{'environment.remote'}=$userenv{'remote'}; if ($userenv{'texengine'} eq 'ttm') { $clientmathml=1; } # --------------- Do not trust query string to be put directly into environment - foreach my $option ('imagesuppress','appletsuppress', - 'embedsuppress','fontenhance','blackwhite', - 'interface','localpath','localres') { - $form->{$option}=~s/[\n\r\=]//gs; + foreach my $option ('interface','localpath','localres') { + $form->{$option}=~s/[\n\r\=]//gs; } # --------------------------------------------------------- Write first profile @@ -9848,34 +13893,58 @@ sub init_user_environment { $initial_env{"browser.localres"} = $form->{'localres'}; } - if ($public) { - $initial_env{"environment.remote"} = "off"; - } if ($form->{'interface'}) { $form->{'interface'}=~s/\W//gs; $initial_env{"browser.interface"} = $form->{'interface'}; $env{'browser.interface'}=$form->{'interface'}; - foreach my $option ('imagesuppress','appletsuppress', - 'embedsuppress','fontenhance','blackwhite') { - if (($form->{$option} eq 'true') || - ($userenv{$option} eq 'on')) { - $initial_env{"browser.$option"} = "on"; - } - } } - 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', + \%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'}); } @@ -9911,7 +13980,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 (); } } @@ -9945,6 +14016,254 @@ 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 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.', + 'reCAPTCHA refresh'). + '

    '; +} + +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