--- loncom/interface/loncommon.pm 2002/07/03 21:12:38 1.43
+++ loncom/interface/loncommon.pm 2002/07/12 14:36:16 1.46
@@ -1,7 +1,7 @@
# The LearningOnline Network with CAPA
# a pile of common routines
#
-# $Id: loncommon.pm,v 1.43 2002/07/03 21:12:38 ng Exp $
+# $Id: loncommon.pm,v 1.46 2002/07/12 14:36:16 matthew Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -41,6 +41,8 @@
# POD header:
+=pod
+
=head1 NAME
Apache::loncommon - pile of common routines
@@ -77,26 +79,48 @@ package Apache::loncommon;
use strict;
use Apache::lonnet();
+use GDBM_File;
use POSIX qw(strftime);
use Apache::Constants qw(:common);
use Apache::lonmsg();
my $readit;
+=pod
+
+=item Global Variables
+
+=over 4
+
+=cut
# ----------------------------------------------- Filetypes/Languages/Copyright
my %language;
my %cprtag;
my %fe; my %fd;
my %category_extensions;
-# -------------------------------------------------------------- Thesaurus data
-my @therelated;
-my @theword;
-my @thecount;
-my %theindex;
-my $thetotalcount;
-my $thefuzzy=2;
-my $thethreshold=0.1/$thefuzzy;
-my $theavecount;
+# ---------------------------------------------- Thesaurus variables
+
+=pod
+
+=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.
+
+=cut
+
+my %Keywords;
+my $thesaurus_db_file;
+
+
+=pod
+
+=back
+
+=cut
# ----------------------------------------------------------------------- BEGIN
@@ -105,13 +129,16 @@ my $theavecount;
=item BEGIN()
Initialize values from language.tab, copyright.tab, filetypes.tab,
-and filecategories.tab.
+thesaurus.tab, and filecategories.tab.
=cut
+
# ----------------------------------------------------------------------- BEGIN
BEGIN {
-
+ # Variable initialization
+ $thesaurus_db_file = $Apache::lonnet::perlvar{'lonTabDir'}."/thesaurus.db";
+ #
unless ($readit) {
# ------------------------------------------------------------------- languages
{
@@ -168,26 +195,10 @@ BEGIN {
}
}
}
-# -------------------------------------------------------------- Thesaurus data
- {
- my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.
- '/thesaurus.dat');
- if ($fh) {
- while (<$fh>) {
- my ($tword,$tindex,$tcount,$trelated)=split(/\@/,$_);
- $theindex{$tword}=$tindex;
- $theword[$tindex]=$tword;
- $thecount[$tindex]=$tcount;
- $thetotalcount+=$tcount;
- $therelated[$tindex]=$trelated;
- }
- }
- $theavecount=$thetotalcount/$#thecount;
- }
&Apache::lonnet::logthis(
- "<font color=yellow>INFO: Read file types and thesaurus</font>");
+ "<font color=yellow>INFO: Read file types</font>");
$readit=1;
-}
+ } # end of unless($readit)
}
# ============================================================= END BEGIN BLOCK
@@ -342,8 +353,6 @@ my %menu = ( A1 => { text =>"Choice A1"
}
);
-=back
-
=cut
# ------------------------------------------------
@@ -428,6 +437,52 @@ END
###############################################################
+=pod
+
+=item help_open_topic($topic, $stayOnPage, $width, $height)
+
+Returns a string corresponding to an HTML link to the given help $topic, where $topic corresponds to the name of a .tex file in /home/httpd/html/adm/help/tex, with underscores replaced by spaces.
+
+$stayOnPage is a value that will be interpreted as a boolean. If true, the link will not open a new window. If false, the link will open a new window using Javascript. (Default is false.)
+
+$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.
+
+=cut
+
+sub help_open_topic {
+ my ($topic, $stayOnPage, $width, $height) = @_;
+ $stayOnPage = 0 if (not defined $stayOnPage);
+ $width = 350 if (not defined $width);
+ $height = 400 if (not defined $height);
+ my $filename = $topic;
+ $filename =~ s/ /_/g;
+
+ my $template;
+
+ if (!$stayOnPage)
+ {
+ $template = <<"ENDTEMPLATE";
+<a href="javascript:void(open('/adm/help/${filename}.hlp', 'Help for $topic', 'menubar=0,s
+crollbars=1,width=$width,height=$height'))"><image
+ src="/adm/help/gif/smallHelp.gif"
+ border="0" alt="(Help: $topic)"></a>
+ENDTEMPLATE
+ }
+ else
+ {
+ $template = <<"ENDTEMPLATE";
+<a href="/adm/help/${filename}.hlp"><image
+ src="/adm/help/gif/smallHelp.gif"
+ border="0" alt="(Help: $topic)"></a>
+ENDTEMPLATE
+ }
+
+ return $template;
+
+}
+
+=pod
+
=item csv_translate($text)
Translate $text to allow it to be output as a 'comma seperated values'
@@ -443,12 +498,12 @@ sub csv_translate {
}
###############################################################
-
-###############################################################
## Home server <option> list generating code ##
###############################################################
#-------------------------------------------
+=pod
+
=item get_domains()
Returns an array containing each of the domains listed in the hosts.tab
@@ -469,6 +524,8 @@ sub get_domains {
#-------------------------------------------
+=pod
+
=item select_dom_form($defdom,$name)
Returns a string containing a <select name='$name' size='1'> form to
@@ -493,6 +550,8 @@ sub select_dom_form {
#-------------------------------------------
+=pod
+
=item get_home_servers($domain)
Returns a hash which contains keys like '103l3' and values like
@@ -515,6 +574,8 @@ sub get_home_servers {
#-------------------------------------------
+=pod
+
=item home_server_option_list($domain)
returns a string which contains an <option> list to be used in a
@@ -547,6 +608,8 @@ sub home_server_option_list {
## formname = the name given in the <form> tag.
#-------------------------------------------
+=pod
+
=item authform_xxxxxx
The authform_xxxxxx subroutines provide javascript and html forms which
@@ -748,66 +811,166 @@ END
## End Authentication changing form generation functions ##
###############################################################
+###############################################################
+## Thesaurus Functions ##
+###############################################################
+=pod
-# ---------------------------------------------------------- Is this a keyword?
+=item initialize_keywords
-sub keyword {
- my $newword=shift;
- $newword=~s/\W//g;
- $newword=~tr/A-Z/a-z/;
- my $tindex=$theindex{$newword};
- if ($tindex) {
- if ($thecount[$tindex]>$theavecount) {
- return 1;
- }
+Initializes the package variable %Keywords if it is empty. Uses the
+package variable $thesaurus_db_file.
+
+=cut
+
+###################################################
+
+sub initialize_keywords {
+ return 1 if (scalar keys(%Keywords));
+ # If we are here, %Keywords is empty, so fill it up
+ # Make sure the file we need exists...
+ if (! -e $thesaurus_db_file) {
+ &Apache::lonnet::logthis("Attempt to access $thesaurus_db_file".
+ " failed because it does not exist");
+ return 0;
+ }
+ # Set up the hash as a database
+ my %thesaurus_db;
+ if (! tie(%thesaurus_db,'GDBM_File',
+ $thesaurus_db_file,&GDBM_READER,0640)){
+ &Apache::lonnet::logthis("Could not tie \%thesaurus_db to ".
+ $thesaurus_db_file);
+ return 0;
+ }
+ # Get the average number of appearances of a word.
+ my $avecount = $thesaurus_db{'average.count'};
+ # Put keywords (those that appear > average) into %Keywords
+ while (my ($word,$data)=each (%thesaurus_db)) {
+ my ($count,undef) = split /:/,$data;
+ $Keywords{$word}++ if ($count > $avecount);
+ }
+ untie %thesaurus_db;
+ # Remove special values from %Keywords.
+ foreach ('total.count','average.count') {
+ delete($Keywords{$_}) if (exists($Keywords{$_}));
}
- return 0;
+ return 1;
}
+
+###################################################
+
+=pod
+
+=item keyword($word)
+
+Returns true if $word is a keyword. A keyword is a word that appears more
+than the average number of times in the thesaurus database. Calls
+&initialize_keywords
+
+=cut
+
+###################################################
+
+sub keyword {
+ return if (!&initialize_keywords());
+ my $word=lc(shift());
+ $word=~s/\W//g;
+ return exists($Keywords{$word});
+}
+
+###################################################
+# Old code, to be removed soon #
+###################################################
# -------------------------------------------------------- Return related words
+#sub related {
+# my $newword=shift;
+# $newword=~s/\W//g;
+# $newword=~tr/A-Z/a-z/;
+# my $tindex=$theindex{$newword};
+# if ($tindex) {
+# my %found=();
+# foreach (split(/\,/,$therelated[$tindex])) {
+## - Related word found
+# my ($ridx,$rcount)=split(/\:/,$_);
+## - Direct relation index
+# my $directrel=$rcount/$thecount[$tindex];
+# if ($directrel>$thethreshold) {
+# foreach (split(/\,/,$therelated[$ridx])) {
+# my ($rridx,$rrcount)=split(/\:/,$_);
+# if ($rridx==$tindex) {
+## - Determine reverse relation index
+# my $revrel=$rrcount/$thecount[$ridx];
+## - Calculate full index
+# $found{$ridx}=$directrel*$revrel;
+# if ($found{$ridx}>$thethreshold) {
+# foreach (split(/\,/,$therelated[$ridx])) {
+# my ($rrridx,$rrrcount)=split(/\:/,$_);
+# unless ($found{$rrridx}) {
+# my $revrevrel=$rrrcount/$thecount[$ridx];
+# if (
+# $directrel*$revrel*$revrevrel>$thethreshold
+# ) {
+# $found{$rrridx}=
+# $directrel*$revrel*$revrevrel;
+# }
+# }
+# }
+# }
+# }
+# }
+# }
+# }
+# }
+# return ();
+#}
-sub related {
- my $newword=shift;
- $newword=~s/\W//g;
- $newword=~tr/A-Z/a-z/;
- my $tindex=$theindex{$newword};
- if ($tindex) {
- my %found=();
- foreach (split(/\,/,$therelated[$tindex])) {
-# - Related word found
- my ($ridx,$rcount)=split(/\:/,$_);
-# - Direct relation index
- my $directrel=$rcount/$thecount[$tindex];
- if ($directrel>$thethreshold) {
- foreach (split(/\,/,$therelated[$ridx])) {
- my ($rridx,$rrcount)=split(/\:/,$_);
- if ($rridx==$tindex) {
-# - Determine reverse relation index
- my $revrel=$rrcount/$thecount[$ridx];
-# - Calculate full index
- $found{$ridx}=$directrel*$revrel;
- if ($found{$ridx}>$thethreshold) {
- foreach (split(/\,/,$therelated[$ridx])) {
- my ($rrridx,$rrrcount)=split(/\:/,$_);
- unless ($found{$rrridx}) {
- my $revrevrel=$rrrcount/$thecount[$ridx];
- if (
- $directrel*$revrel*$revrevrel>$thethreshold
- ) {
- $found{$rrridx}=
- $directrel*$revrel*$revrevrel;
- }
- }
- }
- }
- }
- }
- }
+###############################################################
+
+=pod
+
+=item get_related_words
+
+Look up a word in the thesaurus. Takes a scalar arguement and returns
+an array of words. If the keyword is not in the thesaurus, an empty array
+will be returned. The order of the words returned is determined by the
+database which holds them.
+
+Uses global $thesaurus_db_file.
+
+=cut
+
+###############################################################
+
+sub get_related_words {
+ my $keyword = shift;
+ my %thesaurus_db;
+ if (! -e $thesaurus_db_file) {
+ &Apache::lonnet::logthis("Attempt to access $thesaurus_db_file ".
+ "failed because the file does not exist");
+ return ();
+ }
+ if (! tie(%thesaurus_db,'GDBM_File',
+ $thesaurus_db_file,&GDBM_READER,0640)){
+ return ();
+ }
+ my @Words=();
+ if (exists($thesaurus_db{$keyword})) {
+ $_ = $thesaurus_db{$keyword};
+ (undef,@Words) = split/:/; # The first element is the number of times
+ # the word appears. We do not need it now.
+ for (my $i=0;$i<=$#Words;$i++) {
+ ($Words[$i],undef)= split/\,/,$Words[$i];
}
}
- return ();
+ untie %thesaurus_db;
+ return @Words;
}
+###############################################################
+## End Thesaurus Functions ##
+###############################################################
+
# ---------------------------------------------------------------- Language IDs
sub languageids {
return sort(keys(%language));
@@ -1036,6 +1199,8 @@ sub add_to_env {
=pod
+=back
+
=head2 CSV Upload/Handling functions
=over 4