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

Diff for /loncom/interface/loncommon.pm between versions 1.58 and 1.101

version 1.58, 2002/08/22 21:05:25 version 1.101, 2003/05/23 21:18:56
Line 27 Line 27
 #  #
 # YEAR=2001  # YEAR=2001
 # 2/13-12/7 Guy Albertelli  # 2/13-12/7 Guy Albertelli
 # 12/11,12/12,12/17 Scott Harrison  
 # 12/21 Gerd Kortemeyer  # 12/21 Gerd Kortemeyer
 # 12/21 Scott Harrison  
 # 12/25,12/28 Gerd Kortemeyer  # 12/25,12/28 Gerd Kortemeyer
 # YEAR=2002  # YEAR=2002
 # 1/4 Gerd Kortemeyer  # 1/4 Gerd Kortemeyer
Line 81  use strict; Line 79  use strict;
 use Apache::lonnet();  use Apache::lonnet();
 use GDBM_File;  use GDBM_File;
 use POSIX qw(strftime mktime);  use POSIX qw(strftime mktime);
 use Apache::Constants qw(:common);  use Apache::Constants qw(:common :http :methods);
 use Apache::lonmsg();  use Apache::lonmsg();
   use Apache::lonmenu();
 my $readit;  my $readit;
   
 =pod   =pod 
Line 98  my %cprtag; Line 97  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 148  BEGIN { Line 151  BEGIN {
     while (<$fh>) {      while (<$fh>) {
  next if /^\#/;   next if /^\#/;
  chomp;   chomp;
  my ($key,$val)=(split(/\s+/,$_,2));   my ($key,$two,$country,$three,$enc,$val)=(split(/\t/,$_));
  $language{$key}=$val;   $language{$key}=$val.' - '.$enc;
     }      }
  }   }
     }      }
Line 166  BEGIN { Line 169  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 283  sub browser_and_searcher_javascript { Line 310  sub browser_and_searcher_javascript {
 END  END
 }  }
   
   sub studentbrowser_javascript {
      unless ($ENV{'request.course.id'}) { return ''; }  
      unless (&Apache::lonnet::allowed('srm',$ENV{'request.course.id'})) {
           return '';
      }
      return (<<'ENDSTDBRW');
   <script type="text/javascript" language="Javascript" >
       var stdeditbrowser;
       function openstdbrowser(formname,uname,udom) {
           var url = '/adm/pickstudent?';
           var filter;
           eval('filter=document.'+formname+'.'+uname+'.value;');
           if (filter != null) {
              if (filter != '') {
                  url += 'filter='+filter+'&';
      }
           }
           url += 'form=' + formname + '&unameelement='+uname+
                                       '&udomelement='+udom;
           var title = 'Student 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 selectstudent_link {
       my ($form,$unameele,$udomele)=@_;
      unless ($ENV{'request.course.id'}) { return ''; }  
      unless (&Apache::lonnet::allowed('srm',$ENV{'request.course.id'})) {
           return '';
      }
       return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele.
           '","'.$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 455  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 465  sub help_open_topic { Line 562  sub help_open_topic {
   
     if (!$stayOnPage)      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      else
     {      {
Line 475  sub help_open_topic { Line 572  sub help_open_topic {
     # Add the text      # Add the text
     if ($text ne "")      if ($text ne "")
     {      {
  $template .= "<a href=\"$link\">$text</a> ";   $template .= 
     "<table bgcolor='#3333AA' cellspacing='1' cellpadding='1' border='0'><tr>".
     "<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.='</td></tr></table>' };
     return $template;      return $template;
   
 }  }
Line 532  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 605  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 646  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 684  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 745  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 774  sub authform_internal{ Line 991  sub authform_internal{
        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 810  sub authform_filesystem{ Line 1027  sub authform_filesystem{
        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'});">)
 END  END
     return $result;      return $result;
 }  }
Line 820  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 932  sub get_related_words { Line 1232  sub get_related_words {
 ##              End Thesaurus Functions                      ##  ##              End Thesaurus Functions                      ##
 ###############################################################  ###############################################################
   
   # -------------------------------------------------------------- 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 {
       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
   =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 {
       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
   
   =pod
   
   =item screenname($uname,$udom)
   
   Gets a users screenname and returns it as a string
   
   =cut
   
   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>";
   }
   # --------------------------------------------------------------- Notes Wrapper
   
   sub noteswrapper {
       my ($link,$un,$do)=@_;
       return 
   "<a href='/adm/email?recordftf=retrieve&recname=$un&recdom=$do'>$link</a>";
   }
   # ------------------------------------------------------------- Aboutme Wrapper
   
   sub aboutmewrapper {
       my ($link,$username,$domain)=@_;
       return "<a href='/adm/$domain/$username/aboutme'>$link</a>";
   }
   
   # ------------------------------------------------------------ Syllabus Wrapper
   
   
   sub syllabuswrapper {
       my ($link,$un,$do,$tf)=@_;
       if ($tf) { $link='<font color="'.$tf.'">'.$link.'</font>'; }
       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 942  sub languagedescription { Line 1347  sub languagedescription {
     return $language{shift(@_)};      return $language{shift(@_)};
 }  }
   
   # ----------------------------------------------------------- Display Languages
   # returns a hash with all desired display languages
   #
   
   sub display_languages {
       my %languages=();
       if ($ENV{'environment.languages'}) {
    foreach (split(/\s*(\,|\;|\:)\s*/,$ENV{'environment.languages'})) {
       $languages{$_}=1;
           }
       }
       &get_unprocessed_cgi($ENV{'QUERY_STRING'},['displaylanguage']);
       if ($ENV{'form.displaylanguage'}) {
    foreach (split(/\s*(\,|\;|\:)\s*/,$ENV{'form.displaylanguage'})) {
       $languages{$_}=1;
           }
       }
       return %languages;
   }
   
 # --------------------------------------------------------------- Copyright IDs  # --------------------------------------------------------------- Copyright IDs
 sub copyrightids {  sub copyrightids {
     return sort(keys(%cprtag));      return sort(keys(%cprtag));
Line 1061  sub get_previous_attempt { Line 1486  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 1069  sub get_student_view { Line 1494  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 1086  sub get_student_view { Line 1512  sub get_student_view {
 }  }
   
 sub get_student_answers {  sub get_student_answers {
   my ($symb,$username,$domain,$courseid) = @_;    my ($symb,$username,$domain,$courseid,%form) = @_;
   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 1096  sub get_student_answers { Line 1522  sub get_student_answers {
   }    }
   $moreenv{'form.grade_target'}='answer';    $moreenv{'form.grade_target'}='answer';
   &Apache::lonnet::appenv(%moreenv);    &Apache::lonnet::appenv(%moreenv);
   my $userview=&Apache::lonnet::ssi('/res/'.$feedurl);    my $userview=&Apache::lonnet::ssi('/res/'.$feedurl,%form);
   &Apache::lonnet::delenv('form.grade_');    &Apache::lonnet::delenv('form.grade_');
   foreach my $element (@elements) {    foreach my $element (@elements) {
     $ENV{'form.grade_'.$element}=$old{$element};      $ENV{'form.grade_'.$element}=$old{$element};
Line 1128  sub maketime { Line 1554  sub maketime {
 }  }
   
   
   #########################################
   #
   # 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 {  sub findallcourses {
     my %courses=();      my %courses=();
     my $now=time;      my $now=time;
Line 1148  sub findallcourses { Line 1590  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') {
    my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'};
    if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; }
           return '<img src="http://'.$ENV{'HTTP_HOST'}.':'.$lonhttpdPort.
       '/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)=@_;
       if ($ENV{'environment.color.'.$which}) {
    return $ENV{'environment.color.'.$which};
       }
       $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.
    $forcereg, if page should register as content page (relevant for 
               text interface only)
   
   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,$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 1164  sub bodytag { Line 1711  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 1210  sub bodytag { Line 1730  sub bodytag {
     }      }
     unless ($realm) { $realm='&nbsp;'; }      unless ($realm) { $realm='&nbsp;'; }
 # Set messages  # Set messages
     my $messages=localtime();      my $messages=&domainlogo($domain);
 # Output  # Signal existance to Remote unless already done so
     return(<<ENDBODY);      my $addscript='';
       unless (($ENV{'browser.interface'} eq 'textual') || 
               ($ENV{'environment.remote'} eq 'off') || ($addentries)) {
           $addentries=' onLoad="'.&Apache::lonmenu::loadevents().
                    '" onUnload="'.&Apache::lonmenu::unloadevents().'"';
    $addscript=&Apache::lonmenu::registerurl();
       }
   # Port for miniserver
       my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'};
       if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; }
   # construct main body tag
       my $bodytag = <<END;
   $addscript
 <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
       my $upperleft='<img src="http://'.$ENV{'HTTP_HOST'}.':'.
                      $lonhttpdPort.$img.'" />';
       if ($bodyonly) {
           return $bodytag;
       } elsif ($ENV{'browser.interface'} eq 'textual') {
   # 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
 <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="/adm/lonInterFace/$img.jpg" /></td>  $upperleft</td>
 <td bgcolor="$font"><font color='$pgbg'>$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 1240  $addentries> Line 1795  $addentries>
 </table><br>  </table><br>
 ENDBODY  ENDBODY
 }  }
   
   ###############################################
   
   sub get_posted_cgi {
       my $r=shift;
   
       my $buffer;
       
       $r->read($buffer,$r->header_in('Content-length'),0);
       unless ($buffer=~/^(\-+\w+)\s+Content\-Disposition\:\s*form\-data/si) {
    my @pairs=split(/&/,$buffer);
    my $pair;
    foreach $pair (@pairs) {
       my ($name,$value) = split(/=/,$pair);
       $value =~ tr/+/ /;
       $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
       $name  =~ tr/+/ /;
       $name  =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
       &add_to_env("form.$name",$value);
    }
       } else {
    my $contentsep=$1;
    my @lines = split (/\n/,$buffer);
    my $name='';
    my $value='';
    my $fname='';
    my $fmime='';
    my $i;
    for ($i=0;$i<=$#lines;$i++) {
       if ($lines[$i]=~/^$contentsep/) {
    if ($name) {
       chomp($value);
       if ($fname) {
    $ENV{"form.$name.filename"}=$fname;
    $ENV{"form.$name.mimetype"}=$fmime;
       } else {
    $value=~s/\s+$//s;
       }
       &add_to_env("form.$name",$value);
    }
    if ($i<$#lines) {
       $i++;
       $lines[$i]=~
    /Content\-Disposition\:\s*form\-data\;\s*name\=\"([^\"]+)\"/i;
       $name=$1;
       $value='';
       if ($lines[$i]=~/filename\=\"([^\"]+)\"/i) {
    $fname=$1;
    if 
                               ($lines[$i+1]=~/Content\-Type\:\s*([\w\-\/]+)/i) {
    $fmime=$1;
    $i++;
       } else {
    $fmime='';
       }
       } else {
    $fname='';
    $fmime='';
       }
       $i++;
    }
       } else {
    $value.=$lines[$i]."\n";
       }
    }
       }
       $ENV{'request.method'}=$ENV{'REQUEST_METHOD'};
       $r->method_number(M_GET);
       $r->method('GET');
       $r->headers_in->unset('Content-length');
   }
   
 ###############################################  ###############################################
   
 sub get_unprocessed_cgi {  sub get_unprocessed_cgi {
Line 1542  sub csv_samples_select_table { Line 2169  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__;
   
Line 1630  will result in $ENV{'form.uname'} and $E Line 2288  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.58  
changed lines
  Added in v.1.101

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