--- loncom/interface/loncommon.pm 2002/08/12 18:21:42 1.53 +++ loncom/interface/loncommon.pm 2021/06/12 20:51:38 1.1360 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # a pile of common routines # -# $Id: loncommon.pm,v 1.53 2002/08/12 18:21:42 albertel Exp $ +# $Id: loncommon.pm,v 1.1360 2021/06/12 20:51:38 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -25,15 +25,6 @@ # # http://www.lon-capa.org/ # -# YEAR=2001 -# 2/13-12/7 Guy Albertelli -# 12/11,12/12,12/17 Scott Harrison -# 12/21 Gerd Kortemeyer -# 12/21 Scott Harrison -# 12/25,12/28 Gerd Kortemeyer -# YEAR=2002 -# 1/4 Gerd Kortemeyer -# 6/24,7/2 H. K. Ng # Makes a table out of the previous attempts # Inputs result_from_symbread, user, domain, course_id @@ -49,92 +40,160 @@ Apache::loncommon - pile of common routi =head1 SYNOPSIS -Referenced by other mod_perl Apache modules. +Common routines for manipulating connections, student answers, + domains, common Javascript fragments, etc. -Invocation: - &Apache::loncommon::SUBROUTINENAME(ARGUMENTS); +=head1 OVERVIEW -=head1 INTRODUCTION - -Common collection of used subroutines. This collection helps remove +A collection of commonly used subroutines that don't have a natural +home anywhere else. This collection helps remove redundancy from other modules and increase efficiency of memory usage. -Current things done: - - Makes a table out of the previous homework attempts - Inputs result_from_symbread, user, domain, course_id - Reads in non-network-related .tab files - -This is part of the LearningOnline Network with CAPA project -described at http://www.lon-capa.org. - -=head2 General Subroutines - -=over 4 - =cut # End of POD header package Apache::loncommon; use strict; -use Apache::lonnet(); +use Apache::lonnet; use GDBM_File; use POSIX qw(strftime mktime); -use Apache::Constants qw(:common); -use Apache::lonmsg(); +use Apache::lonmenu(); +use Apache::lonenc(); +use Apache::lonlocal; +use Apache::lonnet(); +use HTML::Entities; +use Apache::lonhtmlcommon(); +use Apache::loncoursedata(); +use Apache::lontexconvert(); +use Apache::lonclonecourse(); +use Apache::lonuserutils(); +use Apache::lonuserstate(); +use Apache::courseclassifier(); +use LONCAPA qw(:DEFAULT :match); +use LONCAPA::LWPReq; +use HTTP::Request; +use DateTime::TimeZone; +use DateTime::Locale; +use Encode(); +use Text::Aspell; +use Authen::Captcha; +use Captcha::reCAPTCHA; +use JSON::DWIW; +use Crypt::DES; +use DynaLoader; # for Crypt::DES version +use MIME::Lite; +use MIME::Types; +use File::Copy(); +use File::Path(); +use String::CRC32(); +use Short::URL(); + +# ---------------------------------------------- Designs +use vars qw(%defaultdesign); + my $readit; -=pod -=item Global Variables +## +## Global Variables +## + + +# ----------------------------------------------- SSI with retries: +# + +=pod + +=head1 Server Side include with retries: =over 4 -=cut -# ----------------------------------------------- Filetypes/Languages/Copyright -my %language; -my %cprtag; -my %fe; my %fd; -my %category_extensions; +=item * &ssi_with_retries(resource,retries form) -# ---------------------------------------------- Thesaurus variables +Performs an ssi with some number of retries. Retries continue either +until the result is ok or until the retry count supplied by the +caller is exhausted. -=pod +Inputs: + +=over 4 -=item %Keywords +resource - Identifies the resource to insert. -A hash used by &keyword to determine if a word is considered a keyword. +retries - Count of the number of retries allowed. -=item $thesaurus_db_file +form - Hash that identifies the rendering options. -Scalar containing the full path to the thesaurus database. +=back -=cut +Returns: -my %Keywords; -my $thesaurus_db_file; +=over 4 +content - The content of the response. If retries were exhausted this is empty. -=pod +response - The response from the last attempt (which may or may not have been successful. + +=back =back =cut -# ----------------------------------------------------------------------- BEGIN +sub ssi_with_retries { + my ($resource, $retries, %form) = @_; -=pod -=item BEGIN() + my $ok = 0; # True if we got a good response. + my $content; + my $response; -Initialize values from language.tab, copyright.tab, filetypes.tab, -thesaurus.tab, and filecategories.tab. + # Try to get the ssi done. within the retries count: -=cut + do { + ($content, $response) = &Apache::lonnet::ssi($resource, %form); + $ok = $response->is_success; + if (!$ok) { + &Apache::lonnet::logthis("Failed ssi_with_retries on $resource: ".$response->is_success.', '.$response->code.', '.$response->message); + } + $retries--; + } while (!$ok && ($retries > 0)); + + if (!$ok) { + $content = ''; # On error return an empty content. + } + return ($content, $response); -# ----------------------------------------------------------------------- BEGIN +} + + + +# ----------------------------------------------- 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; +my %category_extensions; + +# ---------------------------------------------- Thesaurus variables +# +# %Keywords: +# A hash used by &keyword to determine if a word is considered a keyword. +# $thesaurus_db_file +# Scalar containing the full path to the thesaurus database. + +my %Keywords; +my $thesaurus_db_file; +# +# Initialize values from language.tab, copyright.tab, filetypes.tab, +# thesaurus.tab, and filecategories.tab. +# BEGIN { # Variable initialization $thesaurus_db_file = $Apache::lonnet::perlvar{'lonTabDir'}."/thesaurus.db"; @@ -142,80 +201,126 @@ BEGIN { unless ($readit) { # ------------------------------------------------------------------- languages { - my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}. - '/language.tab'); - if ($fh) { - while (<$fh>) { - next if /^\#/; - chomp; - my ($key,$val)=(split(/\s+/,$_,2)); - $language{$key}=$val; - } - } + my $langtabfile = $Apache::lonnet::perlvar{'lonTabDir'}. + '/language.tab'; + if ( open(my $fh,'<',$langtabfile) ) { + while (my $line = <$fh>) { + next if ($line=~/^\#/); + chomp($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); + } } # ------------------------------------------------------------------ copyrights { - my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonIncludes'}. - '/copyright.tab'); - if ($fh) { - while (<$fh>) { - next if /^\#/; - chomp; - my ($key,$val)=(split(/\s+/,$_,2)); - $cprtag{$key}=$val; - } - } + my $copyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}. + '/copyright.tab'; + if ( open (my $fh,'<',$copyrightfile) ) { + while (my $line = <$fh>) { + next if ($line=~/^\#/); + chomp($line); + my ($key,$val)=(split(/\s+/,$line,2)); + $cprtag{$key}=$val; + } + close($fh); + } + } +# ----------------------------------------------------------- source copyrights + { + my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}. + '/source_copyright.tab'; + if ( open (my $fh,'<',$sourcecopyrightfile) ) { + while (my $line = <$fh>) { + next if ($line =~ /^\#/); + chomp($line); + my ($key,$val)=(split(/\s+/,$line,2)); + $scprtag{$key}=$val; + } + close($fh); + } + } + +# -------------------------------------------------------------- default domain designs + my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors'; + my $designfile = $designdir.'/default.tab'; + if ( open (my $fh,'<',$designfile) ) { + while (my $line = <$fh>) { + next if ($line =~ /^\#/); + chomp($line); + my ($key,$val)=(split(/\=/,$line)); + if ($val) { $defaultdesign{$key}=$val; } + } + close($fh); } + # ------------------------------------------------------------- file categories { - my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}. - '/filecategories.tab'); - if ($fh) { - while (<$fh>) { - next if /^\#/; - chomp; - my ($extension,$category)=(split(/\s+/,$_,2)); - push @{$category_extensions{lc($category)}},$extension; - } - } + my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}. + '/filecategories.tab'; + if ( open (my $fh,'<',$categoryfile) ) { + while (my $line = <$fh>) { + next if ($line =~ /^\#/); + chomp($line); + my ($extension,$category)=(split(/\s+/,$line,2)); + push(@{$category_extensions{lc($category)}},$extension); + } + close($fh); + } + } # ------------------------------------------------------------------ file types { - my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}. - '/filetypes.tab'); - if ($fh) { - while (<$fh>) { - next if (/^\#/); - chomp; - my ($ending,$emb,$descr)=split(/\s+/,$_,3); - if ($descr ne '') { - $fe{$ending}=lc($emb); - $fd{$ending}=$descr; - } - } - } + my $typesfile = $Apache::lonnet::perlvar{'lonTabDir'}. + '/filetypes.tab'; + if ( open (my $fh,'<',$typesfile) ) { + while (my $line = <$fh>) { + next if ($line =~ /^\#/); + chomp($line); + my ($ending,$emb,$mime,$descr)=split(/\s+/,$line,4); + if ($descr ne '') { + $fe{$ending}=lc($emb); + $fd{$ending}=$descr; + if ($mime ne 'unk') { $fm{$ending}=$mime; } + } + } + close($fh); + } } &Apache::lonnet::logthis( - "INFO: Read file types"); + "INFO: Read file types"); $readit=1; } # end of unless($readit) } -# ============================================================= END BEGIN BLOCK + ############################################################### ## HTML and Javascript Helper Functions ## ############################################################### =pod -=item browser_and_searcher_javascript - -Returns scalar containing javascript to open a browser window -or a searcher window. Also creates +=head1 HTML and Javascript Functions =over 4 -=item openbrowser(formname,elementname,only,omit) [javascript] +=item * &browser_and_searcher_javascript() + +XXReturns a string +containing javascript with two functions, C and +C. Returned string does not contain EscriptE +tags. + +=item * &openbrowser(formname,elementname,only,omit) [javascript] inputs: formname, elementname, only, omit @@ -223,95 +328,788 @@ formname and elementname indicate the na the element that the results of the browsing selection are to be placed in. Specifying 'only' will restrict the browser to displaying only files -with the given extension. Can be a comma seperated list. +with the given extension. Can be a comma separated list. Specifying 'omit' will restrict the browser to NOT displaying files -with the given extension. Can be a comma seperated list. +with the given extension. Can be a comma separated list. -=item opensearcher(formname, elementname) [javascript] +=item * &opensearcher(formname,elementname) [javascript] Inputs: formname, elementname formname and elementname specify the name of the html form and the name of the element the selection from the search results will be placed in. -=back - =cut -############################################################### sub browser_and_searcher_javascript { + my ($mode)=@_; + if (!defined($mode)) { $mode='edit'; } + my $resurl=&escape_single(&lastresurl()); return < END } +sub lastresurl { + if ($env{'environment.lastresurl'}) { + return $env{'environment.lastresurl'} + } else { + return '/res'; + } +} +sub storeresurl { + my $resurl=&Apache::lonnet::clutter(shift); + unless ($resurl=~/^\/res/) { return 0; } + $resurl=~s/\/$//; + &Apache::lonnet::put('environment',{'lastresurl' => $resurl}); + &Apache::lonnet::appenv({'environment.lastresurl' => $resurl}); + return 1; +} -############################################################### +sub studentbrowser_javascript { + unless ( + (($env{'request.course.id'}) && + (&Apache::lonnet::allowed('srm',$env{'request.course.id'}) + || &Apache::lonnet::allowed('srm',$env{'request.course.id'}. + '/'.$env{'request.course.sec'}) + )) + || ($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,$courseadv,$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 ''; + } + $callargs.=",'".&Apache::lonhtmlcommon::entity_encode($clickerid)."'"; + if ($courseadv eq 'only') { + $callargs .= ",'',1,'$courseadv'"; + } elsif ($courseadv eq 'none') { + $callargs .= ",'','','$courseadv'"; + } elsif ($courseadv eq 'condition') { + $callargs .= ",'','','$courseadv'"; + } + return ''. + ''. + &mt('Select User').''; + } + if ($env{'request.role'}=~/^(au|dc|su)/) { + $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,$role_element,$crstype, + $credits_element,$instcode) = @_; + my $wintitle = 'Course_Browser'; + if ($crstype eq 'Community') { + $wintitle = 'Community_Browser'; + } + my $id_functions = &javascript_index_functions(); + 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 userdom; +} + +ENDJS + +} + +sub javascript_array_indexof { + return < +// >> 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; + } +} + +// ]]> + + +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+'&'; + } + } + 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' + ."".$linktext.'' + .''; +} + +sub selectauthor_link { + my ($form,$udom)=@_; + return ''. + &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++) { + if (!field[i].disabled) { + field[i].checked = true; + } + } + } else { + if (!field.disabled) { + field.checked = true; + } + } +} + +function uncheckAll(field) { + if (field.length > 0) { + for (i = 0; i < field.length; i++) { + field[i].checked = false ; + } + } else { + field.checked = false ; + } +} +ENDSCRT + return $jscript; +} + +sub select_timezone { + my ($name,$selected,$onchange,$includeempty,$disabled)=@_; + my $output=' menus. The select menus will be linked in that changing the value of the first menu will result in new values being placed in the second menu. The values in the select menu will appear in alphabetical -order. +order unless a defined order is provided. linked_select_forms takes the following ordered inputs: =over 4 -=item $formname, the name of the
tag +=item * $formname, the name of the tag -=item $middletext, the text which appears between the tags -=item $firstdefault, the default value for the first menu +=item * $firstdefault, the default value for the first menu -=item $firstselectname, the name of the first tag -=item $secondselectname, the name of the second tag -=item $hashref, a reference to a hash containing the data for the menus. +=item * $hashref, a reference to a hash containing the data for the menus. + +=item * $menuorder, the order of values in the first menu + +=item * $onchangefirst, additional javascript call to execute for an onchange + event for the first tag + +=item * $suffix, to differentiate separate uses of select2data javascript + objects in a page. =back @@ -322,233 +1120,1722 @@ first menu value is given in $menu{$choi and text for the second menu are given in the hash pointed to by $menu{$choice1}->{'select2'}. -my %menu = ( A1 => { text =>"Choice A1" , - default => "B3", - select2 => { - B1 => "Choice B1", - B2 => "Choice B2", - B3 => "Choice B3", - B4 => "Choice B4" - } - }, - A2 => { text =>"Choice A2" , - default => "C2", - select2 => { - C1 => "Choice C1", - C2 => "Choice C2", - C3 => "Choice C3" - } - }, - A3 => { text =>"Choice A3" , - default => "D6", - select2 => { - D1 => "Choice D1", - D2 => "Choice D2", - D3 => "Choice D3", - D4 => "Choice D4", - D5 => "Choice D5", - D6 => "Choice D6", - D7 => "Choice D7" - } - } - ); + my %menu = ( A1 => { text =>"Choice A1" , + default => "B3", + select2 => { + B1 => "Choice B1", + B2 => "Choice B2", + B3 => "Choice B3", + B4 => "Choice B4" + }, + order => ['B4','B3','B1','B2'], + }, + A2 => { text =>"Choice A2" , + default => "C2", + select2 => { + C1 => "Choice C1", + C2 => "Choice C2", + C3 => "Choice C3" + }, + order => ['C2','C1','C3'], + }, + A3 => { text =>"Choice A3" , + default => "D6", + select2 => { + D1 => "Choice D1", + D2 => "Choice D2", + D3 => "Choice D3", + D4 => "Choice D4", + D5 => "Choice D5", + D6 => "Choice D6", + D7 => "Choice D7" + }, + order => ['D4','D3','D2','D1','D7','D6','D5'], + } + ); =cut -# ------------------------------------------------ - sub linked_select_forms { my ($formname, $middletext, $firstdefault, $firstselectname, $secondselectname, - $hashref + $hashref, + $menuorder, + $onchangefirst, + $onchangesecond, + $suffix ) = @_; my $second = "document.$formname.$secondselectname"; my $first = "document.$formname.$firstselectname"; # output the javascript to do the changing my $result = ''; - $result.=" END # output the initial values for the selection lists - $result .= "\n"; + my @order = sort(keys(%{$hashref})); + if (ref($menuorder) eq 'ARRAY') { + @order = @{$menuorder}; + } + foreach my $value (@order) { $result.=" \n"; } $result .= "\n"; my %select2 = %{$hashref->{$firstdefault}->{'select2'}}; $result .= $middletext; - $result .= "{$firstdefault}->{'default'}; - foreach my $value (sort(keys(%select2))) { + + my @secondorder = sort(keys(%select2)); + if (ref($hashref->{$firstdefault}->{'order'}) eq 'ARRAY') { + @secondorder = @{$hashref->{$firstdefault}->{'order'}}; + } + foreach my $value (@secondorder) { $result.="