--- loncom/interface/loncommon.pm 2002/08/08 13:06:22 1.50 +++ loncom/interface/loncommon.pm 2003/02/13 21:35:50 1.80 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # a pile of common routines # -# $Id: loncommon.pm,v 1.50 2002/08/08 13:06:22 matthew Exp $ +# $Id: loncommon.pm,v 1.80 2003/02/13 21:35:50 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -27,9 +27,7 @@ # # 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 @@ -80,7 +78,7 @@ package Apache::loncommon; use strict; use Apache::lonnet(); use GDBM_File; -use POSIX qw(strftime); +use POSIX qw(strftime mktime); use Apache::Constants qw(:common); use Apache::lonmsg(); my $readit; @@ -98,6 +96,10 @@ my %cprtag; my %fe; my %fd; my %category_extensions; +# ---------------------------------------------- Designs + +my %designhash; + # ---------------------------------------------- Thesaurus variables =pod @@ -166,6 +168,30 @@ BEGIN { } } } + +# -------------------------------------------------------------- domain designs + + my $filename; + my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors'; + opendir(DIR,$designdir); + 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; } + } + } + } + + } + closedir(DIR); + + # ------------------------------------------------------------- file categories { my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}. @@ -283,7 +309,44 @@ sub browser_and_searcher_javascript { END } +sub studentbrowser_javascript { + unless ($ENV{'request.course.id'}) { return ''; } + unless (&Apache::lonnet::allowed('srm',$ENV{'request.course.id'})) { + return ''; + } + return (<<'ENDSTDBRW'); + +ENDSTDBRW +} +sub selectstudent_link { + my ($form,$unameele,$udomele)=@_; + unless ($ENV{'request.course.id'}) { return ''; } + unless (&Apache::lonnet::allowed('srm',$ENV{'request.course.id'})) { + return ''; + } + return "Select"; +} ############################################################### @@ -455,6 +518,9 @@ sub help_open_topic { my ($topic, $text, $stayOnPage, $width, $height) = @_; $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); $height = 400 if (not defined $height); my $filename = $topic; @@ -465,7 +531,7 @@ sub help_open_topic { if (!$stayOnPage) { - $link = "javascript:void(open('/adm/help/${filename}.hlp', 'Help_for_$topic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height'))"; + $link = "javascript:void(open('/adm/help/${filename}.hlp', 'Help_for_$topic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))"; } else { @@ -475,14 +541,16 @@ sub help_open_topic { # Add the text if ($text ne "") { - $template .= "$text "; + $template .= + "". + "
$text"; } # Add the graphic $template .= <<"ENDTEMPLATE"; -(Help: $topic) + (Help: $topic) ENDTEMPLATE - + if ($text ne '') { $template.='
' }; return $template; } @@ -558,7 +626,7 @@ sub select_dom_form { =pod -=item get_home_servers($domain) +=item get_library_servers($domain) Returns a hash which contains keys like '103l3' and values like 'kirk.lite.msu.edu'. All of the keys will be for machines in the @@ -567,15 +635,15 @@ given $domain. =cut #------------------------------------------- -sub get_home_servers { +sub get_library_servers { my $domain = shift; - my %home_servers; + my %library_servers; foreach (keys(%Apache::lonnet::libserv)) { if ($Apache::lonnet::hostdom{$_} eq $domain) { - $home_servers{$_} = $Apache::lonnet::hostname{$_}; + $library_servers{$_} = $Apache::lonnet::hostname{$_}; } } - return %home_servers; + return %library_servers; } #------------------------------------------- @@ -592,7 +660,7 @@ returns a string which contains an 'cu', - kerb_def_dom => 'MSU.EDU', + kerb_def_dom => '', @_, ); $in{'formname'} = 'document.' . $in{'formname'}; my $result=''; + +#---------------------------------------------- Code for upper case translation + my $Javascript_toUpperCase; + unless ($in{kerb_def_dom}) { + $Javascript_toUpperCase =<<"END"; + switch (choice) { + case 'krb': currentform.elements[choicearg].value = + currentform.elements[choicearg].value.toUpperCase(); + break; + default: + } +END + } else { + $Javascript_toUpperCase = ""; + } + $result.=<<"END"; var current = new Object(); current.radiovalue = 'nochange'; @@ -684,12 +768,7 @@ function changed_radio(choice,currentfor function changed_text(choice,currentform) { var choicearg = choice + 'arg'; if (currentform.elements[choicearg].value !='') { - switch (choice) { - case 'krb': currentform.elements[choicearg].value = - currentform.elements[choicearg].value.toUpperCase(); - break; - default: - } + $Javascript_toUpperCase // clear old field if ((current.argfield != choicearg) && (current.argfield != null)) { currentform.elements[current.argfield].value = ''; @@ -735,7 +814,7 @@ sub authform_nochange{ my $result=''; $result.=<<"END"; + onclick="javascript:changed_radio('nochange',$in{'formname'});" /> Do not change login data END return $result; @@ -745,16 +824,26 @@ sub authform_kerberos{ my %in = ( formname => 'document.cu', kerb_def_dom => 'MSU.EDU', + kerb_def_auth => 'krb4', @_, ); my $result=''; + my $check4; + my $check5; + if ($in{'kerb_def_auth'} eq 'krb5') { + $check5 = " checked=\"on\""; + } else { + $check4 = " checked=\"on\""; + } $result.=<<"END"; + onchange="javascript:changed_radio('krb',$in{'formname'});" /> Kerberos authenticated with domain - + +Version 4 +Version 5 END return $result; } @@ -769,10 +858,10 @@ sub authform_internal{ $result.=<<"END"; + onclick="javascript:changed_radio('int',$args{'formname'});" /> Internally authenticated (with initial password + onchange="javascript:changed_text('int',$args{'formname'});" />) END return $result; } @@ -787,10 +876,10 @@ sub authform_local{ $result.=<<"END"; + onclick="javascript:changed_radio('loc',$in{'formname'});" /> Local Authentication with argument + onchange="javascript:changed_text('loc',$in{'formname'});" /> END return $result; } @@ -805,10 +894,10 @@ sub authform_filesystem{ $result.=<<"END"; + onclick="javascript:changed_radio('fsys',$in{'formname'});" /> Filesystem authenticated (with initial password + onchange="javascript:changed_text('fsys',$in{'formname'});">) END return $result; } @@ -818,6 +907,89 @@ END ############################################################### ############################################################### +## Get Authentication Defaults for Domain ## +############################################################### +## +## Returns default authentication type and an associated argument +## as listed in file domain.tab +## +#------------------------------------------- + +=pod + +=item get_auth_defaults + +get_auth_defaults($target_domain) returns the default authentication +type and an associated argument (initial password or a kerberos domain). +These values are stored in lonTabs/domain.tab + +($def_auth, $def_arg) = &get_auth_defaults($target_domain); + +If target_domain is not found in domain.tab, returns nothing (''). + +=over 4 + +=item get_auth_defaults + +=back + +=cut + +#------------------------------------------- +sub get_auth_defaults { + my $domain=shift; + return ($Apache::lonnet::domain_auth_def{$domain},$Apache::lonnet::domain_auth_arg_def{$domain}); +} +############################################################### +## End Get Authentication Defaults for Domain ## +############################################################### + +############################################################### +## Get Kerberos Defaults for Domain ## +############################################################### +## +## Returns default kerberos version and an associated argument +## as listed in file domain.tab. If not listed, provides +## appropriate default domain and kerberos version. +## +#------------------------------------------- + +=pod + +=item get_kerberos_defaults + +get_kerberos_defaults($target_domain) returns the default kerberos +version and domain. If not found in domain.tabs, it defaults to +version 4 and the domain of the server. + +($def_version, $def_krb_domain) = &get_kerberos_defaults($target_domain); + +=over 4 + +=item get_kerberos_defaults + +=back + +=cut + +#------------------------------------------- +sub get_kerberos_defaults { + my $domain=shift; + my ($krbdef,$krbdefdom) = + &Apache::loncommon::get_auth_defaults($domain); + unless ($krbdef =~/^krb/ && $krbdefdom) { + $ENV{'SERVER_NAME'}=~/(\w+\.\w+)$/; + my $krbdefdom=$1; + $krbdefdom=~tr/a-z/A-Z/; + $krbdef = "krb4"; + } + return ($krbdef,$krbdefdom); +} +############################################################### +## End Get Kerberos Defaults for Domain ## +############################################################### + +############################################################### ## Thesaurus Functions ## ############################################################### @@ -844,7 +1016,7 @@ sub initialize_keywords { # Set up the hash as a database my %thesaurus_db; if (! tie(%thesaurus_db,'GDBM_File', - $thesaurus_db_file,&GDBM_READER,0640)){ + $thesaurus_db_file,&GDBM_READER(),0640)){ &Apache::lonnet::logthis("Could not tie \%thesaurus_db to ". $thesaurus_db_file); return 0; @@ -885,52 +1057,6 @@ sub keyword { 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 (); -#} - ############################################################### =pod @@ -947,7 +1073,6 @@ Uses global $thesaurus_db_file. =cut ############################################################### - sub get_related_words { my $keyword = shift; my %thesaurus_db; @@ -957,7 +1082,7 @@ sub get_related_words { return (); } if (! tie(%thesaurus_db,'GDBM_File', - $thesaurus_db_file,&GDBM_READER,0640)){ + $thesaurus_db_file,&GDBM_READER(),0640)){ return (); } my @Words=(); @@ -977,6 +1102,79 @@ sub get_related_words { ## End Thesaurus Functions ## ############################################################### +# -------------------------------------------------------------- Plaintext name + +sub plainname { + my ($uname,$udom)=@_; + my %names=&Apache::lonnet::get('environment', + ['firstname','middlename','lastname','generation'], + $udom,$uname); + my $name=$names{'firstname'}.' '.$names{'middlename'}.' '. + $names{'lastname'}.' '.$names{'generation'}; + $name=~s/\s+$//; + $name=~s/\s+/ /g; + return $name; +} + +# -------------------------------------------------------------------- Nickname + + +sub nickname { + my ($uname,$udom)=@_; + my %names=&Apache::lonnet::get('environment', + ['nickname','firstname','middlename','lastname','generation'],$udom,$uname); + my $name=$names{'nickname'}; + if ($name) { + $name='"'.$name.'"'; + } else { + $name=$names{'firstname'}.' '.$names{'middlename'}.' '. + $names{'lastname'}.' '.$names{'generation'}; + $name=~s/\s+$//; + $name=~s/\s+/ /g; + } + return $name; +} + + +# ------------------------------------------------------------------ Screenname + +sub screenname { + my ($uname,$udom)=@_; + my %names= + &Apache::lonnet::get('environment',['screenname'],$udom,$uname); + return $names{'screenname'}; +} + +# ------------------------------------------------------------- Message Wrapper + +sub messagewrapper { + my ($link,$un,$do)=@_; + return +"$link"; +} +# --------------------------------------------------------------- Notes Wrapper + +sub noteswrapper { + my ($link,$un,$do)=@_; + return +"$link"; +} +# ------------------------------------------------------------- Aboutme Wrapper + +sub aboutmewrapper { + my ($link,$username,$domain)=@_; + return "$link"; +} + +# ------------------------------------------------------------ Syllabus Wrapper + + +sub syllabuswrapper { + my ($link,$un,$do,$tf)=@_; + if ($tf) { $link=''.$link.''; } + return "$link"; +} + # ---------------------------------------------------------------- Language IDs sub languageids { return sort(keys(%language)); @@ -1106,7 +1304,7 @@ sub get_previous_attempt { } sub get_student_view { - my ($symb,$username,$domain,$courseid) = @_; + my ($symb,$username,$domain,$courseid,$target) = @_; my ($map,$id,$feedurl) = split(/___/,$symb); my (%old,%moreenv); my @elements=('symb','courseid','domain','username'); @@ -1114,6 +1312,7 @@ sub get_student_view { $old{$element}=$ENV{'form.grade_'.$element}; $moreenv{'form.grade_'.$element}=eval '$'.$element #' } + if ($target eq 'tex') {$moreenv{'form.grade_target'} = 'tex';} &Apache::lonnet::appenv(%moreenv); my $userview=&Apache::lonnet::ssi('/res/'.$feedurl); &Apache::lonnet::delenv('form.grade_'); @@ -1151,6 +1350,237 @@ sub get_student_answers { ############################################### + +sub timehash { + my @ltime=localtime(shift); + return ( 'seconds' => $ltime[0], + 'minutes' => $ltime[1], + 'hours' => $ltime[2], + 'day' => $ltime[3], + 'month' => $ltime[4]+1, + 'year' => $ltime[5]+1900, + 'weekday' => $ltime[6], + 'dayyear' => $ltime[7]+1, + 'dlsav' => $ltime[8] ); +} + +sub maketime { + my %th=@_; + return POSIX::mktime( + ($th{'seconds'},$th{'minutes'},$th{'hours'}, + $th{'day'},$th{'month'}-1,$th{'year'}-1900,0,0,$th{'dlsav'})); +} + + +######################################### +# +# Retro-fixing of un-backward-compatible time format + +sub unsqltime { + my $timestamp=shift; + if ($timestamp=~/^(\d+)\-(\d+)\-(\d+)\s+(\d+)\:(\d+)\:(\d+)$/) { + $timestamp=&maketime( + 'year'=>$1,'month'=>$2,'day'=>$3, + 'hours'=>$4,'minutes'=>$5,'seconds'=>$6); + } + return $timestamp; +} + +######################################### + +sub findallcourses { + my %courses=(); + my $now=time; + foreach (keys %ENV) { + if ($_=~/^user\.role\.\w+\.\/(\w+)\/(\w+)/) { + my ($starttime,$endtime)=$ENV{$_}; + my $active=1; + if ($starttime) { + if ($now<$starttime) { $active=0; } + } + if ($endtime) { + if ($now>$endtime) { $active=0; } + } + if ($active) { $courses{$1.'_'.$2}=1; } + } + } + return keys %courses; +} + +############################################### +############################################### + +=pod + +=item &determinedomain() + +Inputs: $domain (usually will be undef) + +Returns: Determines which domain should be used for designs + +=cut + +############################################### +sub determinedomain { + my $domain=shift; + if (! $domain) { + # Determine domain if we have not been given one + $domain = $Apache::lonnet::perlvar{'lonDefDomain'}; + if ($ENV{'user.domain'}) { $domain=$ENV{'user.domain'}; } + if ($ENV{'request.role.domain'}) { + $domain=$ENV{'request.role.domain'}; + } + } + return $domain; +} +############################################### +=pod + +=item &domainlogo() + +Inputs: $domain (usually will be undef) + +Returns: A link to a domain logo, if the domain logo exists. +If the domain logo does not exist, a description of the domain. + +=cut +############################################### +sub domainlogo { + my $domain = &determinedomain(shift); + # See if there is a logo + if (-e '/home/httpd/html/adm/lonDomLogos/'.$domain.'.gif') { + return ''; + } elsif(exists($Apache::lonnet::domaindescription{$domain})) { + return $Apache::lonnet::domaindescription{$domain}; + } else { + return ''; + } +} +############################################## + +=pod + +=item &designparm() + +Inputs: $which parameter; $domain (usually will be undef) + +Returns: value of designparamter $which + +=cut +############################################## +sub designparm { + my ($which,$domain)=@_; + $domain=&determinedomain($domain); + if ($designhash{$domain.'.'.$which}) { + return $designhash{$domain.'.'.$which}; + } else { + return $designhash{'default.'.$which}; + } +} + +############################################### +############################################### + +=pod + +=item &bodytag() + +Returns a uniform header for LON-CAPA web pages. + +Inputs: + + $title, A title to be displayed on the page. + $function, the current role (can be undef). + $addentries, extra parameters for the tag. + $bodyonly, if defined, only return the tag. + $domain, if defined, force a given domain. + +Returns: A uniform header for LON-CAPA web pages. +If $bodyonly is nonzero, a string containing a tag will be returned. +If $bodyonly is undef or zero, an html string containing a tag and +other decorations will be returned. + +=cut + +############################################### + + +############################################### +sub bodytag { + my ($title,$function,$addentries,$bodyonly,$domain)=@_; + unless ($function) { + $function='student'; + if ($ENV{'request.role'}=~/^(cc|in|ta|ep)/) { + $function='coordinator'; + } + if ($ENV{'request.role'}=~/^(su|dc|ad|li)/) { + $function='admin'; + } + if (($ENV{'request.role'}=~/^(au|ca)/) || + ($ENV{'REQUEST_URI'}=~/^(\/priv|\~)/)) { + $function='author'; + } + } + my $img=&designparm($function.'.img',$domain); + my $pgbg=&designparm($function.'.pgbg',$domain); + my $tabbg=&designparm($function.'.tabbg',$domain); + my $font=&designparm($function.'.font',$domain); + my $link=&designparm($function.'.link',$domain); + my $alink=&designparm($function.'.alink',$domain); + my $vlink=&designparm($function.'.vlink',$domain); + my $sidebg=&designparm($function.'.sidebg',$domain); + + # role and realm + my ($role,$realm) + =&Apache::lonnet::plaintext((split(/\./,$ENV{'request.role'}))[0]); +# realm + if ($ENV{'request.course.id'}) { + $realm= + $ENV{'course.'.$ENV{'request.course.id'}.'.description'}; + } + unless ($realm) { $realm=' '; } +# Set messages + my $messages=&domainlogo($domain); +# Output + my $bodytag = < +END + if ($bodyonly) { + return $bodytag; + } elsif ($ENV{'browser.interface'} eq 'textual') { + return $bodytag.'

LON-CAPA: '.$title. + '

Main Menu
'; + } else { + return(< + + +$messages + + + + $title + + + $ENV{'environment.firstname'} + $ENV{'environment.middlename'} + $ENV{'environment.lastname'} + $ENV{'environment.generation'} +   + + + +$role  + + +$realm  +
+ENDBODY + } +} ############################################### sub get_unprocessed_cgi { @@ -1236,6 +1666,8 @@ sub upfile_store { return $datatoken; } +=pod + =item load_tmp_file($r) Load uploaded file from tmp, $r should be the HTTP Request object, @@ -1257,6 +1689,8 @@ sub load_tmp_file { $ENV{'form.upfile'}=join('',@studentdata); } +=pod + =item upfile_record_sep() Separate uploaded file into records @@ -1272,6 +1706,8 @@ sub upfile_record_sep { } } +=pod + =item record_sep($record) Separate a record into fields $record should be an item from the upfile_record_sep(), needs $ENV{'form.upfiletype'} @@ -1322,6 +1758,8 @@ sub record_sep { return %components; } +=pod + =item upfile_select_html() return HTML code to select file and specify its type @@ -1330,7 +1768,7 @@ return HTML code to select file and spec sub upfile_select_html { return (<<'ENDUPFORM'); - +
Type: