--- loncom/interface/loncommon.pm 2003/08/20 18:18:45 1.112 +++ loncom/interface/loncommon.pm 2005/07/12 15:54:19 1.270 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # a pile of common routines # -# $Id: loncommon.pm,v 1.112 2003/08/20 18:18:45 bowersj2 Exp $ +# $Id: loncommon.pm,v 1.270 2005/07/12 15:54:19 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -25,13 +25,6 @@ # # http://www.lon-capa.org/ # -# YEAR=2001 -# 2/13-12/7 Guy Albertelli -# 12/21 Gerd Kortemeyer -# 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 @@ -62,23 +55,25 @@ redundancy from other modules and increa package Apache::loncommon; use strict; -use Apache::lonnet(); +use Apache::lonnet; use GDBM_File; use POSIX qw(strftime mktime); use Apache::Constants qw(:common :http :methods); -use Apache::lonmsg(); use Apache::lonmenu(); -my $readit; - -=pod +use Apache::lonlocal; +use HTML::Entities; -=head1 Global Variables +my $readit; -=cut +## +## Global Variables +## # ----------------------------------------------- Filetypes/Languages/Copyright my %language; +my %supported_language; my %cprtag; +my %scprtag; my %fe; my %fd; my %category_extensions; @@ -87,50 +82,19 @@ my %category_extensions; my %designhash; # ---------------------------------------------- Thesaurus variables - -# FIXME: I don't think it's necessary to document these things; -# they're privately used - Jeremy - -=pod - -=over 4 - -=item * %Keywords - -A hash used by &keyword to determine if a word is considered a keyword. - -=item * $thesaurus_db_file - -Scalar containing the full path to the thesaurus database. - -=back - -=cut +# +# %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; -# ----------------------------------------------------------------------- BEGIN - -# FIXME: I don't think this needs to be documented, it prepares -# private data structures - Jeremy -=pod - -=head1 General Subroutines - -=over 4 - -=item * BEGIN() - -Initialize values from language.tab, copyright.tab, filetypes.tab, -thesaurus.tab, and filecategories.tab. - -=back - -=cut - -# ----------------------------------------------------------------------- BEGIN - +# +# 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"; @@ -138,29 +102,48 @@ BEGIN { unless ($readit) { # ------------------------------------------------------------------- languages { - my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}. - '/language.tab'); - if ($fh) { - while (<$fh>) { - next if /^\#/; - chomp; - my ($key,$two,$country,$three,$enc,$val)=(split(/\t/,$_)); - $language{$key}=$val.' - '.$enc; - } - } + my $langtabfile = $Apache::lonnet::perlvar{'lonTabDir'}. + '/language.tab'; + if ( open(my $fh,"<$langtabfile") ) { + while (<$fh>) { + next if /^\#/; + chomp; + my ($key,$two,$country,$three,$enc,$val,$sup)=(split(/\t/,$_)); + $language{$key}=$val.' - '.$enc; + if ($sup) { + $supported_language{$key}=$sup; + } + } + 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 (<$fh>) { + next if /^\#/; + chomp; + my ($key,$val)=(split(/\s+/,$_,2)); + $cprtag{$key}=$val; + } + close($fh); + } + } +# ------------------------------------------------------------------ source copyrights + { + my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}. + '/source_copyright.tab'; + if ( open (my $fh,"<$sourcecopyrightfile") ) { + while (<$fh>) { + next if /^\#/; + chomp; + my ($key,$val)=(split(/\s+/,$_,2)); + $scprtag{$key}=$val; + } + close($fh); + } } # -------------------------------------------------------------- domain designs @@ -171,15 +154,16 @@ BEGIN { while ($filename=readdir(DIR)) { my ($domain)=($filename=~/^(\w+)\./); { - my $fh=Apache::File->new($designdir.'/'.$filename); - if ($fh) { - while (<$fh>) { - next if /^\#/; - chomp; - my ($key,$val)=(split(/\=/,$_)); - if ($val) { $designhash{$domain.'.'.$key}=$val; } - } - } + my $designfile = $designdir.'/'.$filename; + if ( open (my $fh,"<$designfile") ) { + while (<$fh>) { + next if /^\#/; + chomp; + my ($key,$val)=(split(/\=/,$_)); + if ($val) { $designhash{$domain.'.'.$key}=$val; } + } + close($fh); + } } } @@ -188,32 +172,35 @@ BEGIN { # ------------------------------------------------------------- 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 (<$fh>) { + next if /^\#/; + chomp; + my ($extension,$category)=(split(/\s+/,$_,2)); + push @{$category_extensions{lc($category)}},$extension; + } + close($fh); + } + } # ------------------------------------------------------------------ file types { - my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}. - '/filetypes.tab'); - if ($fh) { + my $typesfile = $Apache::lonnet::perlvar{'lonTabDir'}. + '/filetypes.tab'; + if ( open (my $fh,"<$typesfile") ) { while (<$fh>) { - next if (/^\#/); - chomp; - my ($ending,$emb,$descr)=split(/\s+/,$_,3); - if ($descr ne '') { - $fe{$ending}=lc($emb); - $fd{$ending}=$descr; - } - } - } + next if (/^\#/); + chomp; + my ($ending,$emb,$descr)=split(/\s+/,$_,3); + if ($descr ne '') { + $fe{$ending}=lc($emb); + $fd{$ending}=$descr; + } + } + close($fh); + } } &Apache::lonnet::logthis( "INFO: Read file types"); @@ -239,8 +226,6 @@ containing javascript with two functions C. Returned string does not contain EscriptE tags. -=over 4 - =item * openbrowser(formname,elementname,only,omit) [javascript] inputs: formname, elementname, only, omit @@ -249,10 +234,10 @@ 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] @@ -261,43 +246,59 @@ 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=&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'}))) - || ($ENV{'request.role'}=~/^(au|dc|su)/) + (($env{'request.course.id'}) && + (&Apache::lonnet::allowed('srm',$env{'request.course.id'}))) + || ($env{'request.role'}=~/^(au|dc|su)/) ) { return ''; } return (<<'ENDSTDBRW'); + (Help Menu) +ENDTEMPLATE + if ($component_help) { + if (!$text) { + $template=&help_open_topic($component_help,undef,$stayOnPage, + $width,$height).' '.$template; + } else { + my $help_text; + $help_text=&Apache::lonnet::unescape($topic); + $template='
'. + &help_open_topic($component_help,$help_text,$stayOnPage, + $width,$height).''.$template. + '
'; + } + } + if ($text ne '') { $template.='' }; + return $template; +} + +sub help_open_bug { + my ($topic, $text, $stayOnPage, $width, $height) = @_; + 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); + + $topic=~s/\W+/\+/g; + my $link=''; + my $template=''; + my $url=$Apache::lonnet::perlvar{'BugzillaHost'}.'enter_bug.cgi?product=LON-CAPA&bug_file_loc='. + &Apache::lonnet::escape($ENV{'REQUEST_URI'}).'&component='.$topic; + if (!$stayOnPage) + { + $link = "javascript:void(open('$url', 'Bugzilla', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))"; + } + else + { + $link = $url; + } + # Add the text + if ($text ne "") + { + $template .= + "". + "
$text"; + } + + # Add the graphic + my $title = &mt('Report a Bug'); + my $bugicon=&lonhttpdurl("/adm/lonMisc/smallBug.gif"); + $template .= <<"ENDTEMPLATE"; + (Bug: $topic) +ENDTEMPLATE + if ($text ne '') { $template.='
' }; + return $template; + +} + +sub help_open_faq { + my ($topic, $text, $stayOnPage, $width, $height) = @_; + 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); + + $topic=~s/\W+/\+/g; + my $link=''; + my $template=''; + my $url=$Apache::lonnet::perlvar{'FAQHost'}.'/fom/cache/'.$topic.'.html'; + if (!$stayOnPage) + { + $link = "javascript:void(open('$url', 'FAQ-O-Matic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))"; + } + else + { + $link = $url; + } + + # Add the text + if ($text ne "") + { + $template .= + "". + "
$text"; + } + + # Add the graphic + my $title = &mt('View the FAQ'); + my $faqicon=&lonhttpdurl("/adm/lonMisc/smallFAQ.gif"); + $template .= <<"ENDTEMPLATE"; + (FAQ: $topic) +ENDTEMPLATE + if ($text ne '') { $template.='
' }; + return $template; + +} + +############################################################### +############################################################### + =pod -=item * csv_translate($text) +=item * change_content_javascript(): -Translate $text to allow it to be output as a 'comma seperated values' -format. +This and the next function allow you to create small sections of an +otherwise static HTML page that you can update on the fly with +Javascript, even in Netscape 4. + +The Javascript fragment returned by this function (no EscriptE tag) +must be written to the HTML page once. It will prove the Javascript +function "change(name, content)". Calling the change function with the +name of the section +you want to update, matching the name passed to C, and +the new content you want to put in there, will put the content into +that area. + +B: Netscape 4 only reserves enough space for the changable area +to contain room for the original contents. You need to "make space" +for whatever changes you wish to make, and be B to check your +code in Netscape 4. This feature in Netscape 4 is B powerful; +it's adequate for updating a one-line status display, but little more. +This script will set the space to 100% width, so you only need to +worry about height in Netscape 4. + +Modern browsers are much less limiting, and if you can commit to the +user not using Netscape 4, this feature may be used freely with +pretty much any HTML. + +=cut + +sub change_content_javascript { + # If we're on Netscape 4, we need to use Layer-based code + if ($env{'browser.type'} eq 'netscape' && + $env{'browser.version'} =~ /^4\./) { + return (<. $name is +the name you will use to reference the area later; do not repeat the +same name on a given HTML page more then once. $origContent is what +the area will originally contain, which can be left blank. + +=cut + +sub changable_area { + my ($name, $origContent) = @_; + + if ($env{'browser.type'} eq 'netscape' && + $env{'browser.version'} =~ /^4\./) { + # If this is netscape 4, we need to use the Layer tag + return "$origContent"; + } else { + return "$origContent"; + } +} + +=pod =back +=head1 Excel and CSV file utility routines + +=over 4 + +=cut + +############################################################### +############################################################### + +=pod + +=item * csv_translate($text) + +Translate $text to allow it to be output as a 'comma separated values' +format. + =cut +############################################################### +############################################################### sub csv_translate { my $text = shift; $text =~ s/\"/\"\"/g; - $text =~ s/\n//g; + $text =~ s/\n/ /g; return $text; } ############################################################### +############################################################### + +=pod + +=item * define_excel_formats + +Define some commonly used Excel cell formats. + +Currently supported formats: + +=over 4 + +=item header + +=item bold + +=item h1 + +=item h2 + +=item h3 + +=item h4 + +=item i + +=item date + +=back + +Inputs: $workbook + +Returns: $format, a hash reference. + +=cut + +############################################################### +############################################################### +sub define_excel_formats { + my ($workbook) = @_; + my $format; + $format->{'header'} = $workbook->add_format(bold => 1, + bottom => 1, + align => 'center'); + $format->{'bold'} = $workbook->add_format(bold=>1); + $format->{'h1'} = $workbook->add_format(bold=>1, size=>18); + $format->{'h2'} = $workbook->add_format(bold=>1, size=>16); + $format->{'h3'} = $workbook->add_format(bold=>1, size=>14); + $format->{'h4'} = $workbook->add_format(bold=>1, size=>12); + $format->{'i'} = $workbook->add_format(italic=>1); + $format->{'date'} = $workbook->add_format(num_format=> + 'mm/dd/yyyy hh:mm:ss'); + return $format; +} + +############################################################### +############################################################### + +=pod + +=item * create_workbook + +Create an Excel worksheet. If it fails, output message on the +request object and return undefs. + +Inputs: Apache request object + +Returns (undef) on failure, + Excel worksheet object, scalar with filename, and formats + from &Apache::loncommon::define_excel_formats on success + +=cut + +############################################################### +############################################################### +sub create_workbook { + my ($r) = @_; + # + # Create the excel spreadsheet + my $filename = '/prtspool/'. + $env{'user.name'}.'_'.$env{'user.domain'}.'_'. + time.'_'.rand(1000000000).'.xls'; + 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"). + '

'); + return (undef); + } + # + $workbook->set_tempdir('/home/httpd/perl/tmp'); + # + my $format = &Apache::loncommon::define_excel_formats($workbook); + return ($workbook,$filename,$format); +} + +############################################################### +############################################################### + +=pod + +=item * create_text_file + +Create a file to write to and eventually make available to the usre. +If file creation fails, outputs an error message on the request object and +return undefs. + +Inputs: Apache request object, and file suffix + +Returns (undef) on failure, + Filehandle and filename on success. + +=cut + +############################################################### +############################################################### +sub create_text_file { + my ($r,$suffix) = @_; + if (! defined($suffix)) { $suffix = 'txt'; }; + my $fh; + my $filename = '/prtspool/'. + $env{'user.name'}.'_'.$env{'user.domain'}.'_'. + time.'_'.rand(1000000000).'.'.$suffix; + $fh = Apache::File->new('>/home/httpd'.$filename); + if (! defined($fh)) { + $r->log_error("Couldn't open $filename for output $!"); + $r->print("Problems occured in creating the output file. ". + "This error has been logged. ". + "Please alert your LON-CAPA administrator."); + } + return ($fh,$filename) +} + + +=pod + +=back + +=cut + +############################################################### ## Home server