[BACK]Return to loncommon.pm CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom / interface

Diff for /loncom/interface/loncommon.pm between versions 1.55 and 1.68

version 1.55, 2002/08/21 17:18:08 version 1.68, 2002/09/14 21:01:38
Line 98  my %cprtag; Line 98  my %cprtag;
 my %fe; my %fd;  my %fe; my %fd;
 my %category_extensions;  my %category_extensions;
   
   # ---------------------------------------------- Designs
   
   my %designhash;
   
 # ---------------------------------------------- Thesaurus variables  # ---------------------------------------------- Thesaurus variables
   
 =pod  =pod
Line 166  BEGIN { Line 170  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  # ------------------------------------------------------------- file categories
     {      {
  my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.   my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.
Line 480  sub help_open_topic { Line 508  sub help_open_topic {
   
     # Add the graphic      # Add the graphic
     $template .= <<"ENDTEMPLATE";      $template .= <<"ENDTEMPLATE";
 <a href="$link"><image src="/adm/help/gif/smallHelp.gif" border="0" alt="(Help: $topic)"></a>  <a href="$link"><image src="/adm/help/gif/smallHelp.gif" border="0" alt="(Help: $topic)" /></a>
 ENDTEMPLATE  ENDTEMPLATE
   
     return $template;      return $template;
Line 735  sub authform_nochange{ Line 763  sub authform_nochange{
     my $result='';      my $result='';
     $result.=<<"END";      $result.=<<"END";
 <input type="radio" name="login" value="nochange" checked="checked"  <input type="radio" name="login" value="nochange" checked="checked"
        onclick="javascript:changed_radio('nochange',$in{'formname'});">         onclick="javascript:changed_radio('nochange',$in{'formname'});" />
 Do not change login data  Do not change login data
 END  END
     return $result;      return $result;
Line 751  sub authform_kerberos{ Line 779  sub authform_kerberos{
     $result.=<<"END";      $result.=<<"END";
 <input type="radio" name="login" value="krb"   <input type="radio" name="login" value="krb" 
        onclick="javascript:changed_radio('krb',$in{'formname'});"         onclick="javascript:changed_radio('krb',$in{'formname'});"
        onchange="javascript:changed_radio('krb',$in{'formname'});">         onchange="javascript:changed_radio('krb',$in{'formname'});" />
 Kerberos authenticated with domain  Kerberos authenticated with domain
 <input type="text" size="10" name="krbarg" value=""  <input type="text" size="10" name="krbarg" value=""
        onchange="javascript:changed_text('krb',$in{'formname'});">         onchange="javascript:changed_text('krb',$in{'formname'});" />
   <input type="radio" name="krbver" value="4" checked="on" />Version 4
   <input type="radio" name="krbver" value="5" />Version 5
 END  END
     return $result;      return $result;
 }  }
Line 769  sub authform_internal{ Line 799  sub authform_internal{
     $result.=<<"END";      $result.=<<"END";
 <input type="radio" name="login" value="int"  <input type="radio" name="login" value="int"
        onchange="javascript:changed_radio('int',$args{'formname'});"         onchange="javascript:changed_radio('int',$args{'formname'});"
        onclick="javascript:changed_radio('int',$args{'formname'});">         onclick="javascript:changed_radio('int',$args{'formname'});" />
 Internally authenticated (with initial password   Internally authenticated (with initial password 
 <input type="text" size="10" name="intarg" value=""  <input type="text" size="10" name="intarg" value=""
        onchange="javascript:changed_text('int',$args{'formname'});">         onchange="javascript:changed_text('int',$args{'formname'});" />
 END  END
     return $result;      return $result;
 }  }
Line 787  sub authform_local{ Line 817  sub authform_local{
     $result.=<<"END";      $result.=<<"END";
 <input type="radio" name="login" value="loc"  <input type="radio" name="login" value="loc"
        onchange="javascript:changed_radio('loc',$in{'formname'});"         onchange="javascript:changed_radio('loc',$in{'formname'});"
        onclick="javascript:changed_radio('loc',$in{'formname'});">          onclick="javascript:changed_radio('loc',$in{'formname'});" />
 Local Authentication with argument  Local Authentication with argument
 <input type="text" size="10" name="locarg" value=""  <input type="text" size="10" name="locarg" value=""
        onchange="javascript:changed_text('loc',$in{'formname'});">         onchange="javascript:changed_text('loc',$in{'formname'});" />
 END  END
     return $result;      return $result;
 }  }
Line 805  sub authform_filesystem{ Line 835  sub authform_filesystem{
     $result.=<<"END";      $result.=<<"END";
 <input type="radio" name="login" value="fsys"   <input type="radio" name="login" value="fsys" 
        onchange="javascript:changed_radio('fsys',$in{'formname'});"         onchange="javascript:changed_radio('fsys',$in{'formname'});"
        onclick="javascript:changed_radio('fsys',$in{'formname'});">          onclick="javascript:changed_radio('fsys',$in{'formname'});" />
 Filesystem authenticated (with initial password   Filesystem authenticated (with initial password 
 <input type="text" size="10" name="fsysarg" value=""  <input type="text" size="10" name="fsysarg" value=""
        onchange="javascript:changed_text('fsys',$in{'formname'});">         onchange="javascript:changed_text('fsys',$in{'formname'});">
Line 885  sub keyword { Line 915  sub keyword {
     return exists($Keywords{$word});      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   =pod 
Line 947  Uses global $thesaurus_db_file. Line 931  Uses global $thesaurus_db_file.
 =cut  =cut
   
 ###############################################################  ###############################################################
   
 sub get_related_words {  sub get_related_words {
     my $keyword = shift;      my $keyword = shift;
     my %thesaurus_db;      my %thesaurus_db;
Line 977  sub get_related_words { Line 960  sub get_related_words {
 ##              End Thesaurus Functions                      ##  ##              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='&quot;'.$name.'&quot;'; 
       } 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 
   "<a href='/adm/email?compose=individual&recname=$un&recdom=$do'>$link</a>";
   }
   # ------------------------------------------------------------- Aboutme Wrapper
   
   sub aboutmewrapper {
       my ($link,$un,$do)=@_;
       return "<a href='/adm/$do/$un/aboutme'>$link</a>";
   }
   
   # ------------------------------------------------------------ Syllabus Wrapper
   
   
   sub syllabuswrapper {
       my ($link,$un,$do)=@_;
       return "<a href='/public/$do/$un/syllabus'>$link</a>";
   }
   
 # ---------------------------------------------------------------- Language IDs  # ---------------------------------------------------------------- Language IDs
 sub languageids {  sub languageids {
     return sort(keys(%language));      return sort(keys(%language));
Line 1106  sub get_previous_attempt { Line 1154  sub get_previous_attempt {
 }  }
   
 sub get_student_view {  sub get_student_view {
   my ($symb,$username,$domain,$courseid) = @_;    my ($symb,$username,$domain,$courseid,$target) = @_;
   my ($map,$id,$feedurl) = split(/___/,$symb);    my ($map,$id,$feedurl) = split(/___/,$symb);
   my (%old,%moreenv);    my (%old,%moreenv);
   my @elements=('symb','courseid','domain','username');    my @elements=('symb','courseid','domain','username');
Line 1114  sub get_student_view { Line 1162  sub get_student_view {
     $old{$element}=$ENV{'form.grade_'.$element};      $old{$element}=$ENV{'form.grade_'.$element};
     $moreenv{'form.grade_'.$element}=eval '$'.$element #'      $moreenv{'form.grade_'.$element}=eval '$'.$element #'
   }    }
     if ($target eq 'tex') {$moreenv{'form.grade_target'} = 'tex';}
   &Apache::lonnet::appenv(%moreenv);    &Apache::lonnet::appenv(%moreenv);
   my $userview=&Apache::lonnet::ssi('/res/'.$feedurl);    my $userview=&Apache::lonnet::ssi('/res/'.$feedurl);
   &Apache::lonnet::delenv('form.grade_');    &Apache::lonnet::delenv('form.grade_');
Line 1193  sub findallcourses { Line 1242  sub findallcourses {
 }  }
   
 ###############################################  ###############################################
   ###############################################
   
   =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 '<img src="/adm/lonDomLogos/'.$domain.'.gif" />';
       } 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 <body> tag.
    $bodyonly, if defined, only return the <body> 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 <body> tag will be returned.
   If $bodyonly is undef or zero, an html string containing a <body> tag and 
   other decorations will be returned.
   
   =cut
   
   ###############################################
   
   
   ###############################################
 sub bodytag {  sub bodytag {
     my ($title,$function,$addentries)=@_;      my ($title,$function,$addentries,$bodyonly,$domain)=@_;
     unless ($function) {      unless ($function) {
  $function='student';   $function='student';
         if ($ENV{'request.role'}=~/^(cc|in|ta|ep)/) {          if ($ENV{'request.role'}=~/^(cc|in|ta|ep)/) {
Line 1209  sub bodytag { Line 1355  sub bodytag {
             $function='author';              $function='author';
         }          }
     }      }
     my $img='';      my $img=&designparm($function.'.img',$domain);
     my $pgbg='';      my $pgbg=&designparm($function.'.pgbg',$domain);
     my $tabbg='';      my $tabbg=&designparm($function.'.tabbg',$domain);
     my $font='';      my $font=&designparm($function.'.font',$domain);
     my $link='';      my $link=&designparm($function.'.link',$domain);
     my $alink='#CC0000';      my $alink=&designparm($function.'.alink',$domain);
     my $vlink='';      my $vlink=&designparm($function.'.vlink',$domain);
     if ($function eq 'admin') {      my $sidebg=&designparm($function.'.sidebg',$domain);
         $img='admin';  
         $pgbg='#FFFFCC';   # role and realm
         $tabbg='#CCCC99';  
         $font='#772200';  
         $link='#663300';  
         $vlink='#666600';  
     } elsif ($function eq 'coordinator') {  
         $img='coordinator';  
         $pgbg='#CCFFFF';  
         $tabbg='#CCCCFF';  
         $font='#000044';  
         $link='#003333';  
         $vlink='#006633';  
    } elsif ($function eq 'author') {  
         $img='author';  
         $pgbg='#CCFFFF';  
         $tabbg='#CCFFCC';  
         $font='#004400';  
         $link='#003333';  
         $vlink='#006666';  
     } else {  
         $img='student';  
         $pgbg='#FFFFAA';  
         $tabbg='#FF9900';  
         $font='#991100';  
         $link='#993300';  
         $vlink='#996600';  
     }  
 # role and realm  
     my ($role,$realm)      my ($role,$realm)
        =&Apache::lonnet::plaintext((split(/\./,$ENV{'request.role'}))[0]);         =&Apache::lonnet::plaintext((split(/\./,$ENV{'request.role'}))[0]);
 # realm  # realm
Line 1255  sub bodytag { Line 1374  sub bodytag {
     }      }
     unless ($realm) { $realm='&nbsp;'; }      unless ($realm) { $realm='&nbsp;'; }
 # Set messages  # Set messages
     my $messages=localtime();      my $messages=&domainlogo($domain);
 # Output  # Output
     return(<<ENDBODY);      my $bodytag = <<END;
 <body bgcolor="$pgbg" text="$font" alink="$alink" vlink="$vlink" link="$link"  <body bgcolor="$pgbg" text="$font" alink="$alink" vlink="$vlink" link="$link"
 $addentries>  $addentries>
   END
       if ($bodyonly) {
           return $bodytag;
       } else {
           return(<<ENDBODY);
   $bodytag
 <table width="100%" cellspacing="0" border="0" cellpadding="0">  <table width="100%" cellspacing="0" border="0" cellpadding="0">
 <tr><td bgcolor="$font">  <tr><td bgcolor="$font">
 <img src="/adm/lonInterFace/$img.jpg" /></td>  <img src="$img" /></td>
 <td bgcolor="$font"><font color='$pgbg'>$messages</font></td>  <td bgcolor="$font"><font color='$sidebg'>$messages</font></td>
 </tr>  </tr>
 <tr>  <tr>
 <td rowspan="3" bgcolor="$tabbg">  <td rowspan="3" bgcolor="$tabbg">
Line 1284  $addentries> Line 1409  $addentries>
 <td bgcolor="$tabbg" align="right"><font size="2">$realm</font>&nbsp;</td></tr>  <td bgcolor="$tabbg" align="right"><font size="2">$realm</font>&nbsp;</td></tr>
 </table><br>  </table><br>
 ENDBODY  ENDBODY
       }
 }  }
 ###############################################  ###############################################
   
Line 1370  sub upfile_store { Line 1496  sub upfile_store {
     return $datatoken;      return $datatoken;
 }  }
   
   =pod
   
 =item load_tmp_file($r)  =item load_tmp_file($r)
   
 Load uploaded file from tmp, $r should be the HTTP Request object,  Load uploaded file from tmp, $r should be the HTTP Request object,
Line 1391  sub load_tmp_file { Line 1519  sub load_tmp_file {
     $ENV{'form.upfile'}=join('',@studentdata);      $ENV{'form.upfile'}=join('',@studentdata);
 }  }
   
   =pod
   
 =item upfile_record_sep()  =item upfile_record_sep()
   
 Separate uploaded file into records  Separate uploaded file into records
Line 1406  sub upfile_record_sep { Line 1536  sub upfile_record_sep {
     }      }
 }  }
   
   =pod
   
 =item record_sep($record)  =item record_sep($record)
   
 Separate a record into fields $record should be an item from the upfile_record_sep(), needs $ENV{'form.upfiletype'}  Separate a record into fields $record should be an item from the upfile_record_sep(), needs $ENV{'form.upfiletype'}
Line 1456  sub record_sep { Line 1588  sub record_sep {
     return %components;      return %components;
 }  }
   
   =pod
   
 =item upfile_select_html()  =item upfile_select_html()
   
 return HTML code to select file and specify its type  return HTML code to select file and specify its type
Line 1464  return HTML code to select file and spec Line 1598  return HTML code to select file and spec
   
 sub upfile_select_html {  sub upfile_select_html {
     return (<<'ENDUPFORM');      return (<<'ENDUPFORM');
 <input type="file" name="upfile" size="50">  <input type="file" name="upfile" size="50" />
 <br />Type: <select name="upfiletype">  <br />Type: <select name="upfiletype">
 <option value="csv">CSV (comma separated values, spreadsheet)</option>  <option value="csv">CSV (comma separated values, spreadsheet)</option>
 <option value="space">Space separated</option>  <option value="space">Space separated</option>
Line 1474  sub upfile_select_html { Line 1608  sub upfile_select_html {
 ENDUPFORM  ENDUPFORM
 }  }
   
   =pod
   
 =item csv_print_samples($r,$records)  =item csv_print_samples($r,$records)
   
 Prints a table of sample values from each column uploaded $r is an  Prints a table of sample values from each column uploaded $r is an
Line 1504  sub csv_print_samples { Line 1640  sub csv_print_samples {
     $r->print('</tr></table><br />'."\n");      $r->print('</tr></table><br />'."\n");
 }  }
   
   =pod
   
 =item csv_print_select_table($r,$records,$d)  =item csv_print_select_table($r,$records,$d)
   
 Prints a table to create associations between values and table columns.  Prints a table to create associations between values and table columns.
Line 1536  sub csv_print_select_table { Line 1674  sub csv_print_select_table {
     return $i;      return $i;
 }  }
   
   =pod
   
 =item csv_samples_select_table($r,$records,$d)  =item csv_samples_select_table($r,$records,$d)
   
 Prints a table of sample values from the upload and can make associate samples to internal names.  Prints a table of sample values from the upload and can make associate samples to internal names.
Line 1661  will result in $ENV{'form.uname'} and $E Line 1801  will result in $ENV{'form.uname'} and $E
   
 returns cache-controlling header code  returns cache-controlling header code
   
 =item nocache()   =item no_cache($r) 
   
 specifies header code to not have cache  specifies header code to not have cache
   
Removed from v.1.55  
changed lines
  Added in v.1.68

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>