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

Diff for /loncom/interface/loncommon.pm between versions 1.77 and 1.96

version 1.77, 2003/02/12 01:59:34 version 1.96, 2003/04/19 15:34:06
Line 81  use GDBM_File; Line 81  use GDBM_File;
 use POSIX qw(strftime mktime);  use POSIX qw(strftime mktime);
 use Apache::Constants qw(:common);  use Apache::Constants qw(:common);
 use Apache::lonmsg();  use Apache::lonmsg();
   use Apache::lonmenu();
 my $readit;  my $readit;
   
 =pod   =pod 
Line 345  sub selectstudent_link { Line 346  sub selectstudent_link {
         return '';          return '';
    }     }
     return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele.      return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele.
         '","'.$udomele.'");'."'>Select</a>";          '","'.$udomele.'");'."'>Select User</a>";
   }
   
   sub coursebrowser_javascript {
      return (<<'ENDSTDBRW');
   <script type="text/javascript" language="Javascript" >
       var stdeditbrowser;
       function opencrsbrowser(formname,uname,udom) {
           var url = '/adm/pickcourse?';
           var filter;
           if (filter != null) {
              if (filter != '') {
                  url += 'filter='+filter+'&';
      }
           }
           url += 'form=' + formname + '&cnumelement='+uname+
                                       '&cdomelement='+udom;
           var title = 'Course Browser';
           var options = 'scrollbars=1,resizable=1,menubar=0';
           options += ',width=700,height=600';
           stdeditbrowser = open(url,title,options,'1');
           stdeditbrowser.focus();
       }
   </script>
   ENDSTDBRW
   }
   
   sub selectcourse_link {
      my ($form,$unameele,$udomele)=@_;
       return "<a href='".'javascript:opencrsbrowser("'.$form.'","'.$unameele.
           '","'.$udomele.'");'."'>Select Course</a>";
 }  }
   
 ###############################################################  ###############################################################
Line 518  sub help_open_topic { Line 549  sub help_open_topic {
     my ($topic, $text, $stayOnPage, $width, $height) = @_;      my ($topic, $text, $stayOnPage, $width, $height) = @_;
     $text = "" if (not defined $text);      $text = "" if (not defined $text);
     $stayOnPage = 0 if (not defined $stayOnPage);      $stayOnPage = 0 if (not defined $stayOnPage);
       if ($ENV{'browser.interface'} eq 'textual') {
    $stayOnPage=1;
       }
     $width = 350 if (not defined $width);      $width = 350 if (not defined $width);
     $height = 400 if (not defined $height);      $height = 400 if (not defined $height);
     my $filename = $topic;      my $filename = $topic;
Line 540  sub help_open_topic { Line 574  sub help_open_topic {
     {      {
  $template .=    $template .= 
   "<table bgcolor='#3333AA' cellspacing='1' cellpadding='1' border='0'><tr>".    "<table bgcolor='#3333AA' cellspacing='1' cellpadding='1' border='0'><tr>".
   "<td bgcolor='#5555FF'><a href=\"$link\"><font color='#FFFFFF' size='2'>$text</a>";    "<td bgcolor='#5555FF'><a href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";
     }      }
   
     # 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
     if ($text ne '') { $template.='</font></td></tr></table>' };      if ($text ne '') { $template.='</td></tr></table>' };
     return $template;      return $template;
   
 }  }
Line 597  sub get_domains { Line 631  sub get_domains {
   
 =pod  =pod
   
 =item select_dom_form($defdom,$name)  =item select_form($defdom,$name,%hash)
   
   Returns a string containing a <select name='$name' size='1'> form to 
   allow a user to select options from a hash option_name => displayed text.  
   See lonrights.pm for an example invocation and use.
   
   =cut
   
   #-------------------------------------------
   sub select_form {
       my ($def,$name,%hash) = @_;
       my $selectform = "<select name=\"$name\" size=\"1\">\n";
       foreach (sort keys %hash) {
           $selectform.="<option value=\"$_\" ".
               ($_ eq $def ? 'selected' : '').
                   ">".$hash{$_}."</option>\n";
       }
       $selectform.="</select>";
       return $selectform;
   }
   
   
   #-------------------------------------------
   
   =pod
   
   =item select_dom_form($defdom,$name,$includeempty)
   
 Returns a string containing a <select name='$name' size='1'> form to   Returns a string containing a <select name='$name' size='1'> form to 
 allow a user to select the domain to preform an operation in.    allow a user to select the domain to preform an operation in.  
 See loncreateuser.pm for an example invocation and use.  See loncreateuser.pm for an example invocation and use.
   
   If the $includeempty flag is set, it also includes an empty choice ("no domain
   selected");
   
 =cut  =cut
   
 #-------------------------------------------  #-------------------------------------------
 sub select_dom_form {  sub select_dom_form {
     my ($defdom,$name) = @_;      my ($defdom,$name,$includeempty) = @_;
     my @domains = get_domains();      my @domains = get_domains();
       if ($includeempty) { @domains=('',@domains); }
     my $selectdomain = "<select name=\"$name\" size=\"1\">\n";      my $selectdomain = "<select name=\"$name\" size=\"1\">\n";
     foreach (@domains) {      foreach (@domains) {
         $selectdomain.="<option value=\"$_\" ".          $selectdomain.="<option value=\"$_\" ".
Line 670  sub home_server_option_list { Line 734  sub home_server_option_list {
 ###############################################################  ###############################################################
   
 ###############################################################  ###############################################################
   ###############################################################
   
   =pod
   
   =item &decode_user_agent()
   
   Inputs: $r
   
   Outputs:
   
   =over 4
   
   =item $httpbrowser
   
   =item $clientbrowser
   
   =item $clientversion
   
   =item $clientmathml
   
   =item $clientunicode
   
   =item $clientos
   
   =back
   
   =cut
   
   ###############################################################
   ###############################################################
   sub decode_user_agent {
       my @browsertype=split(/\&/,$Apache::lonnet::perlvar{"lonBrowsDet"});
       my %mathcap=split(/\&/,$$Apache::lonnet::perlvar{"lonMathML"});
       my $httpbrowser=$ENV{"HTTP_USER_AGENT"};
       my $clientbrowser='unknown';
       my $clientversion='0';
       my $clientmathml='';
       my $clientunicode='0';
       for (my $i=0;$i<=$#browsertype;$i++) {
           my ($bname,$match,$notmatch,$vreg,$minv,$univ)=split(/\:/,$browsertype[$i]);
    if (($httpbrowser=~/$match/i)  && ($httpbrowser!~/$notmatch/i)) {
       $clientbrowser=$bname;
               $httpbrowser=~/$vreg/i;
       $clientversion=$1;
               $clientmathml=($clientversion>=$minv);
               $clientunicode=($clientversion>=$univ);
    }
       }
       my $clientos='unknown';
       if (($httpbrowser=~/linux/i) ||
           ($httpbrowser=~/unix/i) ||
           ($httpbrowser=~/ux/i) ||
           ($httpbrowser=~/solaris/i)) { $clientos='unix'; }
       if (($httpbrowser=~/vax/i) ||
           ($httpbrowser=~/vms/i)) { $clientos='vms'; }
       if ($httpbrowser=~/next/i) { $clientos='next'; }
       if (($httpbrowser=~/mac/i) ||
           ($httpbrowser=~/powerpc/i)) { $clientos='mac'; }
       if ($httpbrowser=~/win/i) { $clientos='win'; }
       if ($httpbrowser=~/embed/i) { $clientos='pda'; }
       return ($httpbrowser,$clientbrowser,$clientversion,$clientmathml,
               $clientunicode,$clientos,);
   }
   
   ###############################################################
   ###############################################################
   
   
   ###############################################################
 ##    Authentication changing form generation subroutines    ##  ##    Authentication changing form generation subroutines    ##
 ###############################################################  ###############################################################
 ##  ##
Line 711  See loncreateuser.pm for invocation and Line 844  See loncreateuser.pm for invocation and
 sub authform_header{    sub authform_header{  
     my %in = (      my %in = (
         formname => 'cu',          formname => 'cu',
         kerb_def_dom => 'MSU.EDU',          kerb_def_dom => '',
         @_,          @_,
     );      );
     $in{'formname'} = 'document.' . $in{'formname'};      $in{'formname'} = 'document.' . $in{'formname'};
     my $result='';      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";      $result.=<<"END";
 var current = new Object();  var current = new Object();
 current.radiovalue = 'nochange';  current.radiovalue = 'nochange';
Line 749  function changed_radio(choice,currentfor Line 898  function changed_radio(choice,currentfor
 function changed_text(choice,currentform) {  function changed_text(choice,currentform) {
     var choicearg = choice + 'arg';      var choicearg = choice + 'arg';
     if (currentform.elements[choicearg].value !='') {      if (currentform.elements[choicearg].value !='') {
         switch (choice) {          $Javascript_toUpperCase
             case 'krb': currentform.elements[choicearg].value =  
                 currentform.elements[choicearg].value.toUpperCase();  
                 break;  
             default:  
         }  
         // clear old field          // clear old field
         if ((current.argfield != choicearg) && (current.argfield != null)) {          if ((current.argfield != choicearg) && (current.argfield != null)) {
             currentform.elements[current.argfield].value = '';              currentform.elements[current.argfield].value = '';
Line 810  sub authform_kerberos{ Line 954  sub authform_kerberos{
     my %in = (      my %in = (
               formname => 'document.cu',                formname => 'document.cu',
               kerb_def_dom => 'MSU.EDU',                kerb_def_dom => 'MSU.EDU',
                 kerb_def_auth => 'krb4',
               @_,                @_,
               );                );
     my $result='';      my $result='';
       my $check4;
       my $check5;
       if ($in{'kerb_def_auth'} eq 'krb5') {
          $check5 = " checked=\"on\"";
       } else {
          $check4 = " checked=\"on\"";
       }
     $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="$in{'kerb_def_dom'}"
        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="4" $check4 />Version 4
 <input type="radio" name="krbver" value="5" />Version 5  <input type="radio" name="krbver" value="5" $check5 />Version 5
 END  END
     return $result;      return $result;
 }  }
Line 885  END Line 1037  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                        ##  ##                Thesaurus Functions                        ##
 ###############################################################  ###############################################################
   
Line 998  sub get_related_words { Line 1233  sub get_related_words {
 ###############################################################  ###############################################################
   
 # -------------------------------------------------------------- Plaintext name  # -------------------------------------------------------------- Plaintext name
   =pod
   
   =item plainname($uname,$udom)
   
   Gets a users name and returns it as a string in
   "first middle last generation"
   form
   
   =cut
   
   ###############################################################
 sub plainname {  sub plainname {
     my ($uname,$udom)=@_;      my ($uname,$udom)=@_;
     my %names=&Apache::lonnet::get('environment',      my %names=&Apache::lonnet::get('environment',
Line 1012  sub plainname { Line 1257  sub plainname {
 }  }
   
 # -------------------------------------------------------------------- Nickname  # -------------------------------------------------------------------- Nickname
   =pod
   
   =item nickname($uname,$udom)
   
   Gets a users name and returns it as a string as
   
   "&quot;nickname&quot;"
   
   if the user has a nickname or
   
   "first middle last generation"
   
   if the user does not
   
   =cut
   
 sub nickname {  sub nickname {
     my ($uname,$udom)=@_;      my ($uname,$udom)=@_;
Line 1033  sub nickname { Line 1292  sub nickname {
   
 # ------------------------------------------------------------------ Screenname  # ------------------------------------------------------------------ Screenname
   
   =pod
   
   =item screenname($uname,$udom)
   
   Gets a users screenname and returns it as a string
   
   =cut
   
 sub screenname {  sub screenname {
     my ($uname,$udom)=@_;      my ($uname,$udom)=@_;
     my %names=      my %names=
Line 1344  sub domainlogo { Line 1611  sub domainlogo {
     my $domain = &determinedomain(shift);          my $domain = &determinedomain(shift);    
      # See if there is a logo       # See if there is a logo
     if (-e '/home/httpd/html/adm/lonDomLogos/'.$domain.'.gif') {      if (-e '/home/httpd/html/adm/lonDomLogos/'.$domain.'.gif') {
         return '<img src="http://'.$ENV{'HTTP_HOST'}.':8080/adm/lonDomLogos/'.   my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'};
                $domain.'.gif" />';   if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; }
           return '<img src="http://'.$ENV{'HTTP_HOST'}.':'.$lonhttpdPort.
       '/adm/lonDomLogos/'.$domain.'.gif" />';
     } elsif(exists($Apache::lonnet::domaindescription{$domain})) {      } elsif(exists($Apache::lonnet::domaindescription{$domain})) {
         return $Apache::lonnet::domaindescription{$domain};          return $Apache::lonnet::domaindescription{$domain};
     } else {      } else {
Line 1366  Returns: value of designparamter $which Line 1635  Returns: value of designparamter $which
 ##############################################  ##############################################
 sub designparm {  sub designparm {
     my ($which,$domain)=@_;      my ($which,$domain)=@_;
       if ($ENV{'environment.color.'.$which}) {
    return $ENV{'environment.color.'.$which};
       }
     $domain=&determinedomain($domain);      $domain=&determinedomain($domain);
     if ($designhash{$domain.'.'.$which}) {      if ($designhash{$domain.'.'.$which}) {
  return $designhash{$domain.'.'.$which};   return $designhash{$domain.'.'.$which};
Line 1390  Inputs: Line 1662  Inputs:
  $addentries, extra parameters for the <body> tag.   $addentries, extra parameters for the <body> tag.
  $bodyonly, if defined, only return the <body> tag.   $bodyonly, if defined, only return the <body> tag.
  $domain, if defined, force a given domain.   $domain, if defined, force a given domain.
    $forcereg, if page should register as content page (relevant for 
               text interface only)
   
 Returns: A uniform header for LON-CAPA web pages.    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 nonzero, a string containing a <body> tag will be returned.
Line 1403  other decorations will be returned. Line 1677  other decorations will be returned.
   
 ###############################################  ###############################################
 sub bodytag {  sub bodytag {
     my ($title,$function,$addentries,$bodyonly,$domain)=@_;      my ($title,$function,$addentries,$bodyonly,$domain,$forcereg)=@_;
     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 1438  sub bodytag { Line 1712  sub bodytag {
 # Set messages  # Set messages
     my $messages=&domainlogo($domain);      my $messages=&domainlogo($domain);
 # Output  # Output
       my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'};
       if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; }
     my $bodytag = <<END;      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  END
       my $upperleft='<img src="http://'.$ENV{'HTTP_HOST'}.':'.
                      $lonhttpdPort.$img.'" />';
     if ($bodyonly) {      if ($bodyonly) {
         return $bodytag;          return $bodytag;
     } else {      } elsif ($ENV{'browser.interface'} eq 'textual') {
         return(<<ENDBODY);  # Accessibility
           return $bodytag.&Apache::lonmenu::menubuttons($forcereg,'web',
                                                         $forcereg).
                  '<h1>LON-CAPA: '.$title.'</h1>';
       } elsif ($ENV{'environment.remote'} eq 'off') {
   # No Remote
           return $bodytag.&Apache::lonmenu::menubuttons($forcereg,'web',
                                                         $forcereg).
                  '<table bgcolor="'.$pgbg.'" width="100%" border="0" cellspacing="3" cellpadding="3"><tr><td bgcolor="'.$tabbg.'"><font size="+3" color="'.$font.'"><b>'.$title.
   '</b></font></td></tr></table>';
       }
   
   #
   # Top frame rendering, Remote is up
   #
       return(<<ENDBODY);
 $bodytag  $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="$sidebg">
 <img src="http://$ENV{'HTTP_HOST'}:8080/$img" /></td>  $upperleft</td>
 <td bgcolor="$font"><font color='$sidebg'>$messages</font></td>  <td bgcolor="$sidebg" align="right">$messages&nbsp;</td>
 </tr>  </tr>
 <tr>  <tr>
 <td rowspan="3" bgcolor="$tabbg">  <td rowspan="3" bgcolor="$tabbg">
Line 1471  $bodytag Line 1764  $bodytag
 <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 1775  sub csv_samples_select_table { Line 2067  sub csv_samples_select_table {
     $i--;      $i--;
     return($i);      return($i);
 }  }
   
   =pod
   
   =item check_if_partid_hidden($id,$symb,$udom,$uname)
   
   Returns either 1 or undef
   
   1 if the part is to be hidden, undef if it is to be shown
   
   Arguments are:
   
   $id the id of the part to be checked
   $symb, optional the symb of the resource to check
   $udom, optional the domain of the user to check for
   $uname, optional the username of the user to check for
   
   =cut
   
   sub check_if_partid_hidden {
       my ($id,$symb,$udom,$uname) = @_;
       my $hiddenparts=&Apache::lonnet::EXT('resource.0.parameter_hiddenparts',
    $symb,$udom,$uname);
       my @hiddenlist=split(/,/,$hiddenparts);
       foreach my $checkid (@hiddenlist) {
    if ($checkid =~ /^\s*\Q$id\E\s*$/) { return 1; }
       }
       return undef;
   }
   
   
   
 1;  1;
 __END__;  __END__;
   
Removed from v.1.77  
changed lines
  Added in v.1.96

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