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

Diff for /loncom/interface/loncommon.pm between versions 1.198 and 1.358

version 1.198, 2004/07/12 17:02:07 version 1.358, 2006/05/01 19:28:21
Line 55  redundancy from other modules and increa Line 55  redundancy from other modules and increa
 package Apache::loncommon;  package Apache::loncommon;
   
 use strict;  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 :http :methods);  
 use Apache::lonmsg();  
 use Apache::lonmenu();  use Apache::lonmenu();
 use Apache::lonlocal;  use Apache::lonlocal;
 use HTML::Entities;  use HTML::Entities;
   use Apache::lonhtmlcommon();
   use Apache::loncoursedata();
   use Apache::lontexconvert();
   
 my $readit;  my $readit;
   
Line 75  my %language; Line 76  my %language;
 my %supported_language;  my %supported_language;
 my %cprtag;  my %cprtag;
 my %scprtag;  my %scprtag;
 my %fe; my %fd;  my %fe; my %fd; my %fm;
 my %category_extensions;  my %category_extensions;
   
 # ---------------------------------------------- Designs  # ---------------------------------------------- Designs
Line 106  BEGIN { Line 107  BEGIN {
         my $langtabfile = $Apache::lonnet::perlvar{'lonTabDir'}.          my $langtabfile = $Apache::lonnet::perlvar{'lonTabDir'}.
                                    '/language.tab';                                     '/language.tab';
         if ( open(my $fh,"<$langtabfile") ) {          if ( open(my $fh,"<$langtabfile") ) {
             while (<$fh>) {              while (my $line = <$fh>) {
                 next if /^\#/;                  next if ($line=~/^\#/);
                 chomp;                  chomp($line);
                 my ($key,$two,$country,$three,$enc,$val,$sup)=(split(/\t/,$_));                  my ($key,$two,$country,$three,$enc,$val,$sup)=(split(/\t/,$line));
                 $language{$key}=$val.' - '.$enc;                  $language{$key}=$val.' - '.$enc;
                 if ($sup) {                  if ($sup) {
                     $supported_language{$key}=$sup;                      $supported_language{$key}=$sup;
Line 123  BEGIN { Line 124  BEGIN {
         my $copyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.          my $copyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.
                                   '/copyright.tab';                                    '/copyright.tab';
         if ( open (my $fh,"<$copyrightfile") ) {          if ( open (my $fh,"<$copyrightfile") ) {
             while (<$fh>) {              while (my $line = <$fh>) {
                 next if /^\#/;                  next if ($line=~/^\#/);
                 chomp;                  chomp($line);
                 my ($key,$val)=(split(/\s+/,$_,2));                  my ($key,$val)=(split(/\s+/,$line,2));
                 $cprtag{$key}=$val;                  $cprtag{$key}=$val;
             }              }
             close($fh);              close($fh);
         }          }
     }      }
 # ------------------------------------------------------------------ source copyrights  # ----------------------------------------------------------- source copyrights
     {      {
         my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.          my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.
                                   '/source_copyright.tab';                                    '/source_copyright.tab';
         if ( open (my $fh,"<$sourcecopyrightfile") ) {          if ( open (my $fh,"<$sourcecopyrightfile") ) {
             while (<$fh>) {              while (my $line = <$fh>) {
                 next if /^\#/;                  next if ($line =~ /^\#/);
                 chomp;                  chomp($line);
                 my ($key,$val)=(split(/\s+/,$_,2));                  my ($key,$val)=(split(/\s+/,$line,2));
                 $scprtag{$key}=$val;                  $scprtag{$key}=$val;
             }              }
             close($fh);              close($fh);
Line 153  BEGIN { Line 154  BEGIN {
     my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';      my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';
     opendir(DIR,$designdir);      opendir(DIR,$designdir);
     while ($filename=readdir(DIR)) {      while ($filename=readdir(DIR)) {
    if ($filename!~/\.tab$/) { next; }
  my ($domain)=($filename=~/^(\w+)\./);   my ($domain)=($filename=~/^(\w+)\./);
     {   {
         my $designfile = $designdir.'/'.$filename;      my $designfile = $designdir.'/'.$filename;
         if ( open (my $fh,"<$designfile") ) {      if ( open (my $fh,"<$designfile") ) {
             while (<$fh>) {   while (my $line = <$fh>) {
                 next if /^\#/;      next if ($line =~ /^\#/);
                 chomp;      chomp($line);
                 my ($key,$val)=(split(/\=/,$_));      my ($key,$val)=(split(/\=/,$line));
                 if ($val) { $designhash{$domain.'.'.$key}=$val; }      if ($val) { $designhash{$domain.'.'.$key}=$val; }
             }   }
             close($fh);   close($fh);
         }      }
     }   }
   
     }      }
     closedir(DIR);      closedir(DIR);
Line 176  BEGIN { Line 178  BEGIN {
         my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}.          my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}.
                                   '/filecategories.tab';                                    '/filecategories.tab';
         if ( open (my $fh,"<$categoryfile") ) {          if ( open (my $fh,"<$categoryfile") ) {
             while (<$fh>) {      while (my $line = <$fh>) {
                 next if /^\#/;   next if ($line =~ /^\#/);
                 chomp;   chomp($line);
                 my ($extension,$category)=(split(/\s+/,$_,2));                  my ($extension,$category)=(split(/\s+/,$line,2));
                 push @{$category_extensions{lc($category)}},$extension;                  push @{$category_extensions{lc($category)}},$extension;
             }              }
             close($fh);              close($fh);
Line 191  BEGIN { Line 193  BEGIN {
         my $typesfile = $Apache::lonnet::perlvar{'lonTabDir'}.          my $typesfile = $Apache::lonnet::perlvar{'lonTabDir'}.
                '/filetypes.tab';                 '/filetypes.tab';
         if ( open (my $fh,"<$typesfile") ) {          if ( open (my $fh,"<$typesfile") ) {
             while (<$fh>) {              while (my $line = <$fh>) {
                 next if (/^\#/);   next if ($line =~ /^\#/);
                 chomp;   chomp($line);
                 my ($ending,$emb,$descr)=split(/\s+/,$_,3);                  my ($ending,$emb,$mime,$descr)=split(/\s+/,$line,4);
                 if ($descr ne '') {                  if ($descr ne '') {
                     $fe{$ending}=lc($emb);                      $fe{$ending}=lc($emb);
                     $fd{$ending}=$descr;                      $fd{$ending}=$descr;
                       if ($mime ne 'unk') { $fm{$ending}=$mime; }
                 }                  }
             }              }
             close($fh);              close($fh);
Line 250  of the element the selection from the se Line 253  of the element the selection from the se
 =cut  =cut
   
 sub browser_and_searcher_javascript {  sub browser_and_searcher_javascript {
       my ($mode)=@_;
       if (!defined($mode)) { $mode='edit'; }
     my $resurl=&lastresurl();      my $resurl=&lastresurl();
     return <<END;      return <<END;
   // <!-- BEGIN LON-CAPA Internal
     var editbrowser = null;      var editbrowser = null;
     function openbrowser(formname,elementname,only,omit,titleelement) {      function openbrowser(formname,elementname,only,omit,titleelement) {
         var url = '$resurl/?';          var url = '$resurl/?';
Line 259  sub browser_and_searcher_javascript { Line 265  sub browser_and_searcher_javascript {
             url += 'launch=1&';              url += 'launch=1&';
         }          }
         url += 'catalogmode=interactive&';          url += 'catalogmode=interactive&';
         url += 'mode=edit&';          url += 'mode=$mode&';
         url += 'form=' + formname + '&';          url += 'form=' + formname + '&';
         if (only != null) {          if (only != null) {
             url += 'only=' + only + '&';              url += 'only=' + only + '&';
         }           } else {
               url += 'only=&';
    }
         if (omit != null) {          if (omit != null) {
             url += 'omit=' + omit + '&';              url += 'omit=' + omit + '&';
         }          } else {
               url += 'omit=&';
    }
         if (titleelement != null) {          if (titleelement != null) {
             url += 'titleelement=' + titleelement + '&';              url += 'titleelement=' + titleelement + '&';
         }          } else {
       url += 'titleelement=&';
    }
         url += 'element=' + elementname + '';          url += 'element=' + elementname + '';
         var title = 'Browser';          var title = 'Browser';
         var options = 'scrollbars=1,resizable=1,menubar=0';          var options = 'scrollbars=1,resizable=1,menubar=1,location=1';
         options += ',width=700,height=600';          options += ',width=700,height=600';
         editbrowser = open(url,title,options,'1');          editbrowser = open(url,title,options,'1');
         editbrowser.focus();          editbrowser.focus();
Line 284  sub browser_and_searcher_javascript { Line 296  sub browser_and_searcher_javascript {
             url += 'launch=1&';              url += 'launch=1&';
         }          }
         url += 'catalogmode=interactive&';          url += 'catalogmode=interactive&';
         url += 'mode=edit&';          url += 'mode=$mode&';
         url += 'form=' + formname + '&';          url += 'form=' + formname + '&';
         if (titleelement != null) {          if (titleelement != null) {
             url += 'titleelement=' + titleelement + '&';              url += 'titleelement=' + titleelement + '&';
         }          } else {
       url += 'titleelement=&';
    }
         url += 'element=' + elementname + '';          url += 'element=' + elementname + '';
         var title = 'Search';          var title = 'Search';
         var options = 'scrollbars=1,resizable=1,menubar=0';          var options = 'scrollbars=1,resizable=1,menubar=0';
Line 296  sub browser_and_searcher_javascript { Line 310  sub browser_and_searcher_javascript {
         editsearcher = open(url,title,options,'1');          editsearcher = open(url,title,options,'1');
         editsearcher.focus();          editsearcher.focus();
     }      }
   // END LON-CAPA Internal -->
 END  END
 }  }
   
 sub lastresurl {  sub lastresurl {
     if ($ENV{'environment.lastresurl'}) {      if ($env{'environment.lastresurl'}) {
  return $ENV{'environment.lastresurl'}   return $env{'environment.lastresurl'}
     } else {      } else {
  return '/res';   return '/res';
     }      }
Line 318  sub storeresurl { Line 333  sub storeresurl {
   
 sub studentbrowser_javascript {  sub studentbrowser_javascript {
    unless (     unless (
             (($ENV{'request.course.id'}) &&               (($env{'request.course.id'}) && 
              (&Apache::lonnet::allowed('srm',$ENV{'request.course.id'})))               (&Apache::lonnet::allowed('srm',$env{'request.course.id'})
          || ($ENV{'request.role'}=~/^(au|dc|su)/)        || &Apache::lonnet::allowed('srm',$env{'request.course.id'}.
     '/'.$env{'request.course.sec'})
         ))
            || ($env{'request.role'}=~/^(au|dc|su)/)
           ) { return ''; }              ) { return ''; }  
    return (<<'ENDSTDBRW');     return (<<'ENDSTDBRW');
 <script type="text/javascript" language="Javascript" >  <script type="text/javascript" language="Javascript" >
Line 349  ENDSTDBRW Line 367  ENDSTDBRW
   
 sub selectstudent_link {  sub selectstudent_link {
    my ($form,$unameele,$udomele)=@_;     my ($form,$unameele,$udomele)=@_;
    if ($ENV{'request.course.id'}) {       if ($env{'request.course.id'}) {  
        unless (&Apache::lonnet::allowed('srm',$ENV{'request.course.id'})) {         if (!&Apache::lonnet::allowed('srm',$env{'request.course.id'})
      && !&Apache::lonnet::allowed('srm',$env{'request.course.id'}.
    '/'.$env{'request.course.sec'})) {
    return '';     return '';
        }         }
        return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele.         return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele.
         '","'.$udomele.'");'."'>".&mt('Select User')."</a>";          '","'.$udomele.'");'."'>".&mt('Select User')."</a>";
    }     }
    if ($ENV{'request.role'}=~/^(au|dc|su)/) {     if ($env{'request.role'}=~/^(au|dc|su)/) {
        return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele.         return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele.
         '","'.$udomele.'",1);'."'>".&mt('Select User')."</a>";          '","'.$udomele.'",1);'."'>".&mt('Select User')."</a>";
    }     }
Line 368  sub coursebrowser_javascript { Line 388  sub coursebrowser_javascript {
    return (<<ENDSTDBRW);     return (<<ENDSTDBRW);
 <script type="text/javascript" language="Javascript" >  <script type="text/javascript" language="Javascript" >
     var stdeditbrowser;      var stdeditbrowser;
     function opencrsbrowser(formname,uname,udom,desc) {      function opencrsbrowser(formname,uname,udom,desc,extra_element,multflag) {
         var url = '/adm/pickcourse?';          var url = '/adm/pickcourse?';
         var filter;          var filter;
         if (filter != null) {          if (filter != null) {
Line 385  sub coursebrowser_javascript { Line 405  sub coursebrowser_javascript {
         url += 'form=' + formname + '&cnumelement='+uname+          url += 'form=' + formname + '&cnumelement='+uname+
                             '&cdomelement='+udom+                              '&cdomelement='+udom+
                                     '&cnameelement='+desc;                                      '&cnameelement='+desc;
           if (extra_element !=null && extra_element != '' && formname == 'rolechoice') {
               url += '&roleelement='+extra_element;
               if (domainfilter == null || domainfilter == '') {
                   url += '&domainfilter='+extra_element;
               }
           }
           if (multflag !=null && multflag != '') {
               url += '&multiple='+multflag;
           }
         var title = 'Course_Browser';          var title = 'Course_Browser';
         var options = 'scrollbars=1,resizable=1,menubar=0';          var options = 'scrollbars=1,resizable=1,menubar=0';
         options += ',width=700,height=600';          options += ',width=700,height=600';
Line 396  ENDSTDBRW Line 425  ENDSTDBRW
 }  }
   
 sub selectcourse_link {  sub selectcourse_link {
    my ($form,$unameele,$udomele,$desc)=@_;     my ($form,$unameele,$udomele,$desc,$extra_element,$multflag)=@_;
     return "<a href='".'javascript:opencrsbrowser("'.$form.'","'.$unameele.      return "<a href='".'javascript:opencrsbrowser("'.$form.'","'.$unameele.
         '","'.$udomele.'","'.$desc.'");'."'>".&mt('Select Course')."</a>";          '","'.$udomele.'","'.$desc.'","'.$extra_element.'","'.$multflag.'");'."'>".&mt('Select Course')."</a>";
 }  }
   
   sub check_uncheck_jscript {
       my $jscript = <<"ENDSCRT";
   function checkAll(field) {
       if (field.length > 0) {
           for (i = 0; i < field.length; i++) {
               field[i].checked = true ;
           }
       } else {
           field.checked = true
       }
   }
    
   function uncheckAll(field) {
       if (field.length > 0) {
           for (i = 0; i < field.length; i++) {
               field[i].checked = false ;
           }     } else {
           field.checked = false ;
       }
   }
   ENDSCRT
       return $jscript;
   }
   
   
 =pod  =pod
   
 =item * linked_select_forms(...)  =item * linked_select_forms(...)
Line 481  sub linked_select_forms { Line 535  sub linked_select_forms {
     my $first = "document.$formname.$firstselectname";      my $first = "document.$formname.$firstselectname";
     # output the javascript to do the changing      # output the javascript to do the changing
     my $result = '';      my $result = '';
     $result.="<script>\n";      $result.="<script type=\"text/javascript\">\n";
     $result.="var select2data = new Object();\n";      $result.="var select2data = new Object();\n";
     $" = '","';      $" = '","';
     my $debug = '';      my $debug = '';
Line 530  END Line 584  END
     $result .= "<select size=\"1\" name=\"$firstselectname\" onchange=\"select1_changed()\">\n";      $result .= "<select size=\"1\" name=\"$firstselectname\" onchange=\"select1_changed()\">\n";
     foreach my $value (sort(keys(%$hashref))) {      foreach my $value (sort(keys(%$hashref))) {
         $result.="    <option value=\"$value\" ";          $result.="    <option value=\"$value\" ";
         $result.=" selected=\"true\" " if ($value eq $firstdefault);          $result.=" selected=\"selected\" " if ($value eq $firstdefault);
         $result.=">".&mt($hashref->{$value}->{'text'})."</option>\n";          $result.=">".&mt($hashref->{$value}->{'text'})."</option>\n";
     }      }
     $result .= "</select>\n";      $result .= "</select>\n";
Line 540  END Line 594  END
     my $seconddefault = $hashref->{$firstdefault}->{'default'};      my $seconddefault = $hashref->{$firstdefault}->{'default'};
     foreach my $value (sort(keys(%select2))) {      foreach my $value (sort(keys(%select2))) {
         $result.="    <option value=\"$value\" ";                  $result.="    <option value=\"$value\" ";        
         $result.=" selected=\"true\" " if ($value eq $seconddefault);          $result.=" selected=\"selected\" " if ($value eq $seconddefault);
         $result.=">".&mt($select2{$value})."</option>\n";          $result.=">".&mt($select2{$value})."</option>\n";
     }      }
     $result .= "</select>\n";      $result .= "</select>\n";
Line 576  sub help_open_topic { Line 630  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' ||      if ($env{'browser.interface'} eq 'textual' ||
  $ENV{'environment.remote'} eq 'off' ) {   $env{'environment.remote'} eq 'off' ) {
  $stayOnPage=1;   $stayOnPage=1;
     }      }
     $width = 350 if (not defined $width);      $width = 350 if (not defined $width);
Line 609  sub help_open_topic { Line 663  sub help_open_topic {
   
     # Add the graphic      # Add the graphic
     my $title = &mt('Online Help');      my $title = &mt('Online Help');
       my $helpicon=&lonhttpdurl("/adm/help/gif/smallHelp.gif");
     $template .= <<"ENDTEMPLATE";      $template .= <<"ENDTEMPLATE";
  <a href="$link" title="$title"><image src="/adm/help/gif/smallHelp.gif" border="0" alt="(Help: $topic)" /></a>   <a href="$link" title="$title"><img src="$helpicon" border="0" alt="(Help: $topic)" /></a>
 ENDTEMPLATE  ENDTEMPLATE
     if ($text ne '') { $template.='</td></tr></table>' };      if ($text ne '') { $template.='</td></tr></table>' };
     return $template;      return $template;
Line 641  sub help_open_menu { Line 696  sub help_open_menu {
     my ($color,$topic,$component_help,$function,$faq,$bug,$stayOnPage,$width,$height,$text) = @_;      my ($color,$topic,$component_help,$function,$faq,$bug,$stayOnPage,$width,$height,$text) = @_;
     $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' ||      if ($env{'browser.interface'} eq 'textual' ||
         $ENV{'environment.remote'} eq 'off' ) {          $env{'environment.remote'} eq 'off' ) {
         $stayOnPage=1;          $stayOnPage=1;
     }      }
     $width = 620 if (not defined $width);      $width = 620 if (not defined $width);
     $height = 600 if (not defined $height);      $height = 600 if (not defined $height);
     my $link='';      my $link='';
     my $title = &mt('Choose your help');      my $title = &mt('Get help');
     my $origurl = $ENV{'REQUEST_URI'};      my $origurl = $ENV{'REQUEST_URI'};
       $origurl=~s|^/~|/priv/|;
     my $timestamp = time;      my $timestamp = time;
     foreach (\$color,\$function,\$topic,\$component_help,\$faq,\$bug,\$origurl) {      foreach my $datum (\$color,\$function,\$topic,\$component_help,\$faq,
         $$_ = &Apache::lonnet::escape($$_);         \$bug,\$origurl) {
           $$datum = &Apache::lonnet::escape($$datum);
     }      }
   
     if (!$stayOnPage) {      if (!$stayOnPage) {
          $link = "javascript:helpMenu('open')";           $link = "javascript:helpMenu('open')";
     } else {      } else {
Line 665  sub help_open_menu { Line 721  sub help_open_menu {
     my $template;      my $template;
     if ($text ne "") {      if ($text ne "") {
  $template .=    $template .= 
   "<table bgcolor='#337733' cellspacing='1' cellpadding='1' border='0'><tr>".    "<table bgcolor='#CC3300' cellspacing='1' cellpadding='1' border='0'><tr>".
   "<td bgcolor='#448844'><a href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";    "<td bgcolor='#CC6600'><a href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";
     }      }
       my $nothing=&Apache::lonhtmlcommon::javascript_nothing();
       my $helpicon=&lonhttpdurl("/adm/lonIcons/helpgateway.gif");
       my $start_page =
           &Apache::loncommon::start_page('Help Menu', undef,
          {'frameset'    => 1,
    'js_ready'    => 1,
    'add_entries' => {
       'border' => '0',
       'rows'   => "105,*",},});
       my $end_page =
           &Apache::loncommon::end_page({'frameset' => 1,
         'js_ready' => 1,});
   
     $template .= <<"ENDTEMPLATE";      $template .= <<"ENDTEMPLATE";
  <script>   <script type="text/javascript">
 function helpMenu(caller) {  // <!-- BEGIN LON-CAPA Internal
     if (caller == 'open') {  // <![CDATA[
         newWindow =  window.open("","helpmenu","HEIGHT=$height,WIDTH=$width,resize=yes,scrollbars=yes" )  function helpMenu(target) {
         caller = newWindow.document      var caller = this;
     } else {      if (target == 'open') {
         caller = this.document          var newWindow = null;
     }          try {
     caller.write("<html><head><title>LON-CAPA Help Menu</title><meta http-equiv='pragma' content='no-cache'></head>")              newWindow =  window.open($nothing,"helpmenu","HEIGHT=$height,WIDTH=$width,resizable=yes,scrollbars=yes" )
     caller.write("<frameset rows='105,*' border='0'><frame name='bannerframe'  src='$banner_link'><frame name='bodyframe' src='$details_link'></frameset>")          }
     caller.write("</html>")          catch(error) {
     caller.close()              writeHelp(caller);
     if (caller == newWindow.document) {              return;
         caller.focus()          }
           if (newWindow) {
               caller = newWindow;
           }
     }      }
       writeHelp(caller);
       return;
   }
   function writeHelp(caller) {
       caller.document.writeln('$start_page<frame name="bannerframe"  src="$banner_link" /><frame name="bodyframe" src="$details_link" /> $end_page')
       caller.document.close()
       caller.focus()
 }  }
   // ]]>
   // END LON-CAPA Internal -->
  </script>   </script>
  <a href="$link" title="$title"><image src="/adm/lonMisc/smallFAQ.gif" border="0" alt="(Help Menu)" /></a>   <a href="$link" title="$title"><img src="$helpicon" border="0" alt="(Help Menu)" /></a>
 ENDTEMPLATE  ENDTEMPLATE
       if ($component_help) {
    if (!$text) {
       $template=&help_open_topic($component_help,undef,$stayOnPage,
          $width,$height).' '.$template;
    } else {
       my $help_text;
       $help_text=&Apache::lonnet::unescape($topic);
       $template='<table><tr><td>'.
    &help_open_topic($component_help,$help_text,$stayOnPage,
    $width,$height).'</td><td>'.$template.
    '</td></tr></table>';
    }
       }
     if ($text ne '') { $template.='</td></tr></table>' };      if ($text ne '') { $template.='</td></tr></table>' };
     return $template;      return $template;
 }  }
   
 sub help_open_bug {  sub help_open_bug {
     my ($topic, $text, $stayOnPage, $width, $height) = @_;      my ($topic, $text, $stayOnPage, $width, $height) = @_;
     unless ($ENV{'user.adv'}) { return ''; }      unless ($env{'user.adv'}) { return ''; }
     unless ($Apache::lonnet::perlvar{'BugzillaHost'}) { return ''; }      unless ($Apache::lonnet::perlvar{'BugzillaHost'}) { return ''; }
     $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' ||      if ($env{'browser.interface'} eq 'textual' ||
  $ENV{'environment.remote'} eq 'off' ) {   $env{'environment.remote'} eq 'off' ) {
  $stayOnPage=1;   $stayOnPage=1;
     }      }
     $width = 600 if (not defined $width);      $width = 600 if (not defined $width);
Line 728  sub help_open_bug { Line 822  sub help_open_bug {
   
     # Add the graphic      # Add the graphic
     my $title = &mt('Report a Bug');      my $title = &mt('Report a Bug');
       my $bugicon=&lonhttpdurl("/adm/lonMisc/smallBug.gif");
     $template .= <<"ENDTEMPLATE";      $template .= <<"ENDTEMPLATE";
  <a href="$link" title="$title"><image src="/adm/lonMisc/smallBug.gif" border="0" alt="(Bug: $topic)" /></a>   <a href="$link" title="$title"><img src="$bugicon" border="0" alt="(Bug: $topic)" /></a>
 ENDTEMPLATE  ENDTEMPLATE
     if ($text ne '') { $template.='</td></tr></table>' };      if ($text ne '') { $template.='</td></tr></table>' };
     return $template;      return $template;
Line 738  ENDTEMPLATE Line 833  ENDTEMPLATE
   
 sub help_open_faq {  sub help_open_faq {
     my ($topic, $text, $stayOnPage, $width, $height) = @_;      my ($topic, $text, $stayOnPage, $width, $height) = @_;
     unless ($ENV{'user.adv'}) { return ''; }      unless ($env{'user.adv'}) { return ''; }
     unless ($Apache::lonnet::perlvar{'FAQHost'}) { return ''; }      unless ($Apache::lonnet::perlvar{'FAQHost'}) { return ''; }
     $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' ||      if ($env{'browser.interface'} eq 'textual' ||
  $ENV{'environment.remote'} eq 'off' ) {   $env{'environment.remote'} eq 'off' ) {
  $stayOnPage=1;   $stayOnPage=1;
     }      }
     $width = 350 if (not defined $width);      $width = 350 if (not defined $width);
Line 772  sub help_open_faq { Line 867  sub help_open_faq {
   
     # Add the graphic      # Add the graphic
     my $title = &mt('View the FAQ');      my $title = &mt('View the FAQ');
       my $faqicon=&lonhttpdurl("/adm/lonMisc/smallFAQ.gif");
     $template .= <<"ENDTEMPLATE";      $template .= <<"ENDTEMPLATE";
  <a href="$link" title="$title"><image src="/adm/lonMisc/smallFAQ.gif" border="0" alt="(FAQ: $topic)" /></a>   <a href="$link" title="$title"><img src="$faqicon" border="0" alt="(FAQ: $topic)" /></a>
 ENDTEMPLATE  ENDTEMPLATE
     if ($text ne '') { $template.='</td></tr></table>' };      if ($text ne '') { $template.='</td></tr></table>' };
     return $template;      return $template;
Line 785  ENDTEMPLATE Line 881  ENDTEMPLATE
   
 =pod  =pod
   
   =item * change_content_javascript():
   
   This and the next function allow you to create small sections of an
   otherwise static HTML page that you can update on the fly with
   Javascript, even in Netscape 4.
   
   The Javascript fragment returned by this function (no E<lt>scriptE<gt> tag)
   must be written to the HTML page once. It will prove the Javascript
   function "change(name, content)". Calling the change function with the
   name of the section 
   you want to update, matching the name passed to C<changable_area>, and
   the new content you want to put in there, will put the content into
   that area.
   
   B<Note>: Netscape 4 only reserves enough space for the changable area
   to contain room for the original contents. You need to "make space"
   for whatever changes you wish to make, and be B<sure> to check your
   code in Netscape 4. This feature in Netscape 4 is B<not> powerful;
   it's adequate for updating a one-line status display, but little more.
   This script will set the space to 100% width, so you only need to
   worry about height in Netscape 4.
   
   Modern browsers are much less limiting, and if you can commit to the
   user not using Netscape 4, this feature may be used freely with
   pretty much any HTML.
   
   =cut
   
   sub change_content_javascript {
       # If we're on Netscape 4, we need to use Layer-based code
       if ($env{'browser.type'} eq 'netscape' &&
    $env{'browser.version'} =~ /^4\./) {
    return (<<NETSCAPE4);
    function change(name, content) {
       doc = document.layers[name+"___escape"].layers[0].document;
       doc.open();
       doc.write(content);
       doc.close();
    }
   NETSCAPE4
       } else {
    # Otherwise, we need to use semi-standards-compliant code
    # (technically, "innerHTML" isn't standard but the equivalent
    # is really scary, and every useful browser supports it
    return (<<DOMBASED);
    function change(name, content) {
       element = document.getElementById(name);
       element.innerHTML = content;
    }
   DOMBASED
       }
   }
   
   =pod
   
   =item * changable_area($name, $origContent):
   
   This provides a "changable area" that can be modified on the fly via
   the Javascript code provided in C<change_content_javascript>. $name is
   the name you will use to reference the area later; do not repeat the
   same name on a given HTML page more then once. $origContent is what
   the area will originally contain, which can be left blank.
   
   =cut
   
   sub changable_area {
       my ($name, $origContent) = @_;
   
       if ($env{'browser.type'} eq 'netscape' &&
    $env{'browser.version'} =~ /^4\./) {
    # If this is netscape 4, we need to use the Layer tag
    return "<ilayer width='100%' id='${name}___escape' overflow='none'><layer width='100%' id='$name' overflow='none'>$origContent</layer></ilayer>";
       } else {
    return "<span id='$name'>$origContent</span>";
       }
   }
   
   =pod
   
   =back
   
   =head1 Excel and CSV file utility routines
   
   =over 4
   
   =cut
   
   ###############################################################
   ###############################################################
   
   =pod
   
 =item * csv_translate($text)   =item * csv_translate($text) 
   
 Translate $text to allow it to be output as a 'comma separated values'   Translate $text to allow it to be output as a 'comma separated values' 
Line 797  format. Line 985  format.
 sub csv_translate {  sub csv_translate {
     my $text = shift;      my $text = shift;
     $text =~ s/\"/\"\"/g;      $text =~ s/\"/\"\"/g;
     $text =~ s/\n//g;      $text =~ s/\n/ /g;
     return $text;      return $text;
 }  }
   
   
 ###############################################################  ###############################################################
 ###############################################################  ###############################################################
   
Line 825  Currently supported formats: Line 1012  Currently supported formats:
   
 =item h3  =item h3
   
   =item h4
   
   =item i
   
 =item date  =item date
   
 =back  =back
Line 847  sub define_excel_formats { Line 1038  sub define_excel_formats {
     $format->{'h1'}   = $workbook->add_format(bold=>1, size=>18);      $format->{'h1'}   = $workbook->add_format(bold=>1, size=>18);
     $format->{'h2'}   = $workbook->add_format(bold=>1, size=>16);      $format->{'h2'}   = $workbook->add_format(bold=>1, size=>16);
     $format->{'h3'}   = $workbook->add_format(bold=>1, size=>14);      $format->{'h3'}   = $workbook->add_format(bold=>1, size=>14);
       $format->{'h4'}   = $workbook->add_format(bold=>1, size=>12);
       $format->{'i'}    = $workbook->add_format(italic=>1);
     $format->{'date'} = $workbook->add_format(num_format=>      $format->{'date'} = $workbook->add_format(num_format=>
                                             'mmm d yyyy hh:mm AM/PM');                                              'mm/dd/yyyy hh:mm:ss');
     return $format;      return $format;
 }  }
   
Line 857  sub define_excel_formats { Line 1050  sub define_excel_formats {
   
 =pod  =pod
   
 =item * change_content_javascript():  =item * create_workbook
   
 This and the next function allow you to create small sections of an  Create an Excel worksheet.  If it fails, output message on the
 otherwise static HTML page that you can update on the fly with  request object and return undefs.
 Javascript, even in Netscape 4.  
   
 The Javascript fragment returned by this function (no E<lt>scriptE<gt> tag)  
 must be written to the HTML page once. It will prove the Javascript  
 function "change(name, content)". Calling the change function with the  
 name of the section   
 you want to update, matching the name passed to C<changable_area>, and  
 the new content you want to put in there, will put the content into  
 that area.  
   
 B<Note>: Netscape 4 only reserves enough space for the changable area  Inputs: Apache request object
 to contain room for the original contents. You need to "make space"  
 for whatever changes you wish to make, and be B<sure> to check your  
 code in Netscape 4. This feature in Netscape 4 is B<not> powerful;  
 it's adequate for updating a one-line status display, but little more.  
 This script will set the space to 100% width, so you only need to  
 worry about height in Netscape 4.  
   
 Modern browsers are much less limiting, and if you can commit to the  Returns (undef) on failure, 
 user not using Netscape 4, this feature may be used freely with      Excel worksheet object, scalar with filename, and formats 
 pretty much any HTML.      from &Apache::loncommon::define_excel_formats on success
   
 =cut  =cut
   
 sub change_content_javascript {  ###############################################################
     # If we're on Netscape 4, we need to use Layer-based code  ###############################################################
     if ($ENV{'browser.type'} eq 'netscape' &&  sub create_workbook {
  $ENV{'browser.version'} =~ /^4\./) {      my ($r) = @_;
  return (<<NETSCAPE4);          #
  function change(name, content) {      # Create the excel spreadsheet
     doc = document.layers[name+"___escape"].layers[0].document;      my $filename = '/prtspool/'.
     doc.open();          $env{'user.name'}.'_'.$env{'user.domain'}.'_'.
     doc.write(content);          time.'_'.rand(1000000000).'.xls';
     doc.close();      my $workbook  = Spreadsheet::WriteExcel->new('/home/httpd'.$filename);
  }      if (! defined($workbook)) {
 NETSCAPE4          $r->log_error("Error creating excel spreadsheet $filename: $!");
     } else {          $r->print('<p>'.&mt("Unable to create new Excel file.  ".
  # Otherwise, we need to use semi-standards-compliant code                              "This error has been logged.  ".
  # (technically, "innerHTML" isn't standard but the equivalent                              "Please alert your LON-CAPA administrator").
  # is really scary, and every useful browser supports it                    '</p>');
  return (<<DOMBASED);          return (undef);
  function change(name, content) {  
     element = document.getElementById(name);  
     element.innerHTML = content;  
  }  
 DOMBASED  
     }      }
       #
       $workbook->set_tempdir('/home/httpd/perl/tmp');
       #
       my $format = &Apache::loncommon::define_excel_formats($workbook);
       return ($workbook,$filename,$format);
 }  }
   
   ###############################################################
   ###############################################################
   
 =pod  =pod
   
 =item * changable_area($name, $origContent):  =item * create_text_file
   
 This provides a "changable area" that can be modified on the fly via  Create a file to write to and eventually make available to the usre.
 the Javascript code provided in C<change_content_javascript>. $name is  If file creation fails, outputs an error message on the request object and 
 the name you will use to reference the area later; do not repeat the  return undefs.
 same name on a given HTML page more then once. $origContent is what  
 the area will originally contain, which can be left blank.  
   
 =cut  Inputs: Apache request object, and file suffix
   
 sub changable_area {  Returns (undef) on failure, 
     my ($name, $origContent) = @_;      Filehandle and filename on success.
   
     if ($ENV{'browser.type'} eq 'netscape' &&  =cut
  $ENV{'browser.version'} =~ /^4\./) {  
  # If this is netscape 4, we need to use the Layer tag  ###############################################################
  return "<ilayer width='100%' id='${name}___escape' overflow='none'><layer width='100%' id='$name' overflow='none'>$origContent</layer></ilayer>";  ###############################################################
     } else {  sub create_text_file {
  return "<span id='$name'>$origContent</span>";      my ($r,$suffix) = @_;
       if (! defined($suffix)) { $suffix = 'txt'; };
       my $fh;
       my $filename = '/prtspool/'.
           $env{'user.name'}.'_'.$env{'user.domain'}.'_'.
           time.'_'.rand(1000000000).'.'.$suffix;
       $fh = Apache::File->new('>/home/httpd'.$filename);
       if (! defined($fh)) {
           $r->log_error("Couldn't open $filename for output $!");
           $r->print("Problems occured in creating the output file.  ".
                     "This error has been logged.  ".
                     "Please alert your LON-CAPA administrator.");
     }      }
       return ($fh,$filename)
 }  }
   
 =pod  
   =pod 
   
 =back  =back
   
Line 962  sub get_domains { Line 1154  sub get_domains {
     # The code below was stolen from "The Perl Cookbook", p 102, 1st ed.      # The code below was stolen from "The Perl Cookbook", p 102, 1st ed.
     my @domains;      my @domains;
     my %seen;      my %seen;
     foreach (sort values(%Apache::lonnet::hostdom)) {      foreach my $dom (sort(values(%Apache::lonnet::hostdom))) {
  push (@domains,$_) unless $seen{$_}++;   push(@domains,$dom) unless $seen{$dom}++;
     }      }
     return @domains;      return @domains;
 }  }
Line 977  sub domain_select { Line 1169  sub domain_select {
     } &get_domains;      } &get_domains;
     if ($multiple) {      if ($multiple) {
  $domains{''}=&mt('Any domain');   $domains{''}=&mt('Any domain');
  return &multiple_select_form($name,$value,4,%domains);   return &multiple_select_form($name,$value,4,\%domains);
     } else {      } else {
  return &select_form($name,$value,%domains);   return &select_form($name,$value,%domains);
     }      }
 }  }
   
   #-------------------------------------------
   
   =pod
   
   =item * multiple_select_form($name,$value,$size,$hash,$order)
   
   Returns a string containing a <select> element int multiple mode
   
   
   Args:
     $name - name of the <select> element
     $value - sclara or array ref of values that should already be selected
     $size - number of rows long the select element is
     $hash - the elements should be 'option' => 'shown text'
             (shown text should already have been &mt())
     $order - (optional) array ref of the order to show the elments in
   
   =cut
   
   #-------------------------------------------
 sub multiple_select_form {  sub multiple_select_form {
     my ($name,$value,$size,%hash)=@_;      my ($name,$value,$size,$hash,$order)=@_;
     my %selected = map { $_ => 1 } ref($value)?@{$value}:($value);      my %selected = map { $_ => 1 } ref($value)?@{$value}:($value);
     my $output='';      my $output='';
     if (! defined($size)) {      if (! defined($size)) {
         $size = 4;          $size = 4;
         if (scalar(keys(%hash))<4) {          if (scalar(keys(%$hash))<4) {
             $size = scalar(keys(%hash));              $size = scalar(keys(%$hash));
         }          }
     }      }
     $output.="\n<select name='$name' size='$size' multiple='1'>";      $output.="\n<select name='$name' size='$size' multiple='1'>";
     foreach (sort(keys(%hash))) {      my @order = ref($order) ? @$order
         $output.='<option value="'.$_.'" ';                              : sort(keys(%$hash));
         $output.='selected ' if ($selected{$_});      foreach my $key (@order) {
         $output.='>'.$hash{$_}."</option>\n";          $output.='<option value="'.&HTML::Entities::encode($key,'"<>&').'" ';
           $output.='selected="selected" ' if ($selected{$key});
           $output.='>'.$hash->{$key}."</option>\n";
     }      }
     $output.="</select>\n";      $output.="</select>\n";
     return $output;      return $output;
Line 1025  sub select_form { Line 1239  sub select_form {
     } else {      } else {
  @keys=sort(keys(%hash));   @keys=sort(keys(%hash));
     }      }
     foreach (@keys) {      foreach my $key (@keys) {
         $selectform.="<option value=\"$_\" ".          $selectform.=
             ($_ eq $def ? 'selected' : '').      '<option value="'.&HTML::Entities::encode($key,'"<>&').'" '.
                 ">".&mt($hash{$_})."</option>\n";              ($key eq $def ? 'selected="selected" ' : '').
                   ">".&mt($hash{$key})."</option>\n";
     }      }
     $selectform.="</select>";      $selectform.="</select>";
     return $selectform;      return $selectform;
Line 1064  sub select_level_form { Line 1279  sub select_level_form {
     my $selectform = "<select name=\"$name\" size=\"1\">\n";      my $selectform = "<select name=\"$name\" size=\"1\">\n";
     for (my $i=0; $i<=18; $i++) {      for (my $i=0; $i<=18; $i++) {
         $selectform.="<option value=\"$i\" ".          $selectform.="<option value=\"$i\" ".
             ($i==$deflevel ? 'selected' : '').              ($i==$deflevel ? 'selected="selected" ' : '').
                 ">".&gradeleveldescription($i)."</option>\n";                  ">".&gradeleveldescription($i)."</option>\n";
     }      }
     $selectform.="</select>";      $selectform.="</select>";
Line 1092  sub select_dom_form { Line 1307  sub select_dom_form {
     my @domains = get_domains();      my @domains = get_domains();
     if ($includeempty) { @domains=('',@domains); }      if ($includeempty) { @domains=('',@domains); }
     my $selectdomain = "<select name=\"$name\" size=\"1\">\n";      my $selectdomain = "<select name=\"$name\" size=\"1\">\n";
     foreach (@domains) {      foreach my $dom (@domains) {
         $selectdomain.="<option value=\"$_\" ".          $selectdomain.="<option value=\"$dom\" ".
             ($_ eq $defdom ? 'selected' : '').              ($dom eq $defdom ? 'selected="selected" ' : '').
                 ">$_</option>\n";                  ">$dom</option>\n";
     }      }
     $selectdomain.="</select>";      $selectdomain.="</select>";
     return $selectdomain;      return $selectdomain;
Line 1117  given $domain. Line 1332  given $domain.
 sub get_library_servers {  sub get_library_servers {
     my $domain = shift;      my $domain = shift;
     my %library_servers;      my %library_servers;
     foreach (keys(%Apache::lonnet::libserv)) {      foreach my $hostid (keys(%Apache::lonnet::libserv)) {
         if ($Apache::lonnet::hostdom{$_} eq $domain) {          if ($Apache::lonnet::hostdom{$hostid} eq $domain) {
             $library_servers{$_} = $Apache::lonnet::hostname{$_};              $library_servers{$hostid} = $Apache::lonnet::hostname{$hostid};
         }          }
     }      }
     return %library_servers;      return %library_servers;
Line 1141  sub home_server_option_list { Line 1356  sub home_server_option_list {
     my $domain = shift;      my $domain = shift;
     my %servers = &get_library_servers($domain);      my %servers = &get_library_servers($domain);
     my $result = '';      my $result = '';
     foreach (sort keys(%servers)) {      foreach my $hostid (sort(keys(%servers))) {
         $result.=          $result.=
             '<option value="'.$_.'">'.$_.' '.$servers{$_}."</option>\n";              '<option value="'.$hostid.'">'.
       $hostid.' '.$servers{$hostid}."</option>\n";
     }      }
     return $result;      return $result;
 }  }
Line 1193  Outputs: Line 1409  Outputs:
 ###############################################################  ###############################################################
 ###############################################################  ###############################################################
 sub decode_user_agent {  sub decode_user_agent {
       my ($r)=@_;
     my @browsertype=split(/\&/,$Apache::lonnet::perlvar{"lonBrowsDet"});      my @browsertype=split(/\&/,$Apache::lonnet::perlvar{"lonBrowsDet"});
     my %mathcap=split(/\&/,$$Apache::lonnet::perlvar{"lonMathML"});      my %mathcap=split(/\&/,$$Apache::lonnet::perlvar{"lonMathML"});
     my $httpbrowser=$ENV{"HTTP_USER_AGENT"};      my $httpbrowser=$ENV{"HTTP_USER_AGENT"};
       if (!$httpbrowser && $r) { $httpbrowser=$r->header_in('User-Agent'); }
     my $clientbrowser='unknown';      my $clientbrowser='unknown';
     my $clientversion='0';      my $clientversion='0';
     my $clientmathml='';      my $clientmathml='';
Line 1391  sub authform_nochange{ Line 1609  sub authform_nochange{
               kerb_def_dom => 'MSU.EDU',                kerb_def_dom => 'MSU.EDU',
               @_,                @_,
           );            );
     my $result = &mt('[_1] Do not change login data',      my $result = '<label>'.&mt('[_1] Do not change login data',
                      '<input type="radio" name="login" value="nochange" '.                       '<input type="radio" name="login" value="nochange" '.
                      'checked="checked" onclick="'.                       'checked="checked" onclick="'.
             "javascript:changed_radio('nochange',$in{'formname'});".'" />');              "javascript:changed_radio('nochange',$in{'formname'});".'" />').
       '</label>';
     return $result;      return $result;
 }  }
   
Line 1426  sub authform_kerberos{ Line 1645  sub authform_kerberos{
     my $jscall = "javascript:changed_radio('krb',$in{'formname'});";      my $jscall = "javascript:changed_radio('krb',$in{'formname'});";
     my $result .= &mt      my $result .= &mt
         ('[_1] Kerberos authenticated with domain [_2] '.          ('[_1] Kerberos authenticated with domain [_2] '.
          '[_3] Version 4 [_4] Version 5',           '[_3] Version 4 [_4] Version 5 [_5]',
          '<input type="radio" name="login" value="krb" '.           '<label><input type="radio" name="login" value="krb" '.
              'onclick="'.$jscall.'" onchange="'.$jscall.'"'.$krbcheck.' />',               'onclick="'.$jscall.'" onchange="'.$jscall.'"'.$krbcheck.' />',
          '<input type="text" size="10" name="krbarg" '.           '</label><input type="text" size="10" name="krbarg" '.
              'value="'.$krbarg.'" '.               'value="'.$krbarg.'" '.
              'onchange="'.$jscall.'" />',               'onchange="'.$jscall.'" />',
          '<input type="radio" name="krbver" value="4" '.$check4.' />',           '<label><input type="radio" name="krbver" value="4" '.$check4.' />',
          '<input type="radio" name="krbver" value="5" '.$check5.' />');           '</label><label><input type="radio" name="krbver" value="5" '.$check5.' />',
    '</label>');
     return $result;      return $result;
 }  }
   
Line 1458  sub authform_internal{ Line 1678  sub authform_internal{
     my $jscall = "javascript:changed_radio('int',$args{'formname'});";      my $jscall = "javascript:changed_radio('int',$args{'formname'});";
     my $result.=&mt      my $result.=&mt
         ('[_1] Internally authenticated (with initial password [_2])',          ('[_1] Internally authenticated (with initial password [_2])',
          '<input type="radio" name="login" value="int" '.$intcheck.           '<label><input type="radio" name="login" value="int" '.$intcheck.
              ' onchange="'.$jscall.'" onclick="'.$jscall.'" />',               ' onchange="'.$jscall.'" onclick="'.$jscall.'" />',
          '<input type="text" size="10" name="intarg" '.$intarg.           '</label><input type="text" size="10" name="intarg" '.$intarg.
              ' onchange="'.$jscall.'" />');               ' onchange="'.$jscall.'" />');
     return $result;      return $result;
 }  }
Line 1485  sub authform_local{ Line 1705  sub authform_local{
   
     my $jscall = "javascript:changed_radio('loc',$in{'formname'});";      my $jscall = "javascript:changed_radio('loc',$in{'formname'});";
     my $result.=&mt('[_1] Local Authentication with argument [_2]',      my $result.=&mt('[_1] Local Authentication with argument [_2]',
                     '<input type="radio" name="login" value="loc" '.$loccheck.                      '<label><input type="radio" name="login" value="loc" '.$loccheck.
                         ' onchange="'.$jscall.'" onclick="'.$jscall.'" />',                          ' onchange="'.$jscall.'" onclick="'.$jscall.'" />',
                     '<input type="text" size="10" name="locarg" '.$locarg.                      '</label><input type="text" size="10" name="locarg" '.$locarg.
                         ' onchange="'.$jscall.'" />');                          ' onchange="'.$jscall.'" />');
     return $result;      return $result;
 }  }
Line 1501  sub authform_filesystem{ Line 1721  sub authform_filesystem{
     my $jscall = "javascript:changed_radio('fsys',$in{'formname'});";      my $jscall = "javascript:changed_radio('fsys',$in{'formname'});";
     my $result.= &mt      my $result.= &mt
         ('[_1] Filesystem Authenticated (with initial password [_2])',          ('[_1] Filesystem Authenticated (with initial password [_2])',
          '<input type="radio" name="login" value="fsys" '.           '<label><input type="radio" name="login" value="fsys" '.
          'onchange="'.$jscall.'" onclick="'.$jscall.'" />',           'onchange="'.$jscall.'" onclick="'.$jscall.'" />',
          '<input type="text" size="10" name="fsysarg" value="" '.           '</label><input type="text" size="10" name="fsysarg" value="" '.
                   'onchange="'.$jscall.'" />');                    'onchange="'.$jscall.'" />');
     return $result;      return $result;
 }  }
Line 1629  sub initialize_keywords { Line 1849  sub initialize_keywords {
     }      }
     untie %thesaurus_db;      untie %thesaurus_db;
     # Remove special values from %Keywords.      # Remove special values from %Keywords.
     foreach ('total.count','average.count') {      foreach my $value ('total.count','average.count') {
         delete($Keywords{$_}) if (exists($Keywords{$_}));          delete($Keywords{$value}) if (exists($Keywords{$value}));
     }      }
     return 1;      return 1;
 }  }
Line 1686  sub get_related_words { Line 1906  sub get_related_words {
     }       } 
     my @Words=();      my @Words=();
     if (exists($thesaurus_db{$keyword})) {      if (exists($thesaurus_db{$keyword})) {
         $_ = $thesaurus_db{$keyword};   # The first element is the number of times
         (undef,@Words) = split/:/;  # The first element is the number of times   # the word appears.  We do not need it now.
                                     # the word appears.  We do not need it now.   (undef,@Words) = (split(/:/,$thesaurus_db{$keyword}));
         for (my $i=0;$i<=$#Words;$i++) {          for (my $i=0;$i<=$#Words;$i++) {
             ($Words[$i],undef)= split/\,/,$Words[$i];              ($Words[$i],undef)= split(/\,/,$Words[$i]);
         }          }
     }      }
     untie %thesaurus_db;      untie %thesaurus_db;
Line 1710  sub get_related_words { Line 1930  sub get_related_words {
   
 =over 4  =over 4
   
 =item * plainname($uname,$udom)  =item * plainname($uname,$udom,$first)
   
 Takes a users logon name and returns it as a string in  Takes a users logon name and returns it as a string in
 "first middle last generation" form  "first middle last generation" form 
   if $first is set to 'lastname' then it returns it as
   'lastname generation, firstname middlename' if their is a lastname
   
 =cut  =cut
   
   
 ###############################################################  ###############################################################
 sub plainname {  sub plainname {
     my ($uname,$udom)=@_;      my ($uname,$udom,$first)=@_;
     my %names=&Apache::lonnet::get('environment',      my %names=&getnames($uname,$udom);
                     ['firstname','middlename','lastname','generation'],      my $name=&Apache::lonnet::format_name($names{'firstname'},
  $udom,$uname);    $names{'middlename'},
     my $name=$names{'firstname'}.' '.$names{'middlename'}.' '.    $names{'lastname'},
  $names{'lastname'}.' '.$names{'generation'};    $names{'generation'},$first);
       $name=~s/^\s+//;
     $name=~s/\s+$//;      $name=~s/\s+$//;
     $name=~s/\s+/ /g;      $name=~s/\s+/ /g;
     if ($name !~ /\S/) { $name=$uname.'@'.$udom; }      if ($name !~ /\S/) { $name=$uname.':'.$udom; }
     return $name;      return $name;
 }  }
   
Line 1750  if the user does not Line 1974  if the user does not
   
 sub nickname {  sub nickname {
     my ($uname,$udom)=@_;      my ($uname,$udom)=@_;
     my %names=&Apache::lonnet::get('environment',      my %names=&getnames($uname,$udom);
   ['nickname','firstname','middlename','lastname','generation'],$udom,$uname);  
     my $name=$names{'nickname'};      my $name=$names{'nickname'};
     if ($name) {      if ($name) {
        $name='&quot;'.$name.'&quot;';          $name='&quot;'.$name.'&quot;'; 
Line 1764  sub nickname { Line 1987  sub nickname {
     return $name;      return $name;
 }  }
   
   sub getnames {
       my ($uname,$udom)=@_;
       my $id=$uname.':'.$udom;
       my ($names,$cached)=&Apache::lonnet::is_cached_new('namescache',$id);
       if ($cached) {
    return %{$names};
       } else {
    my %loadnames=&Apache::lonnet::get('environment',
                       ['firstname','middlename','lastname','generation','nickname'],
    $udom,$uname);
    &Apache::lonnet::do_cache_new('namescache',$id,\%loadnames);
    return %loadnames;
       }
   }
   
 # ------------------------------------------------------------------ Screenname  # ------------------------------------------------------------------ Screenname
   
Line 1777  Gets a users screenname and returns it a Line 2014  Gets a users screenname and returns it a
   
 sub screenname {  sub screenname {
     my ($uname,$udom)=@_;      my ($uname,$udom)=@_;
     my %names=      if ($uname eq $env{'user.name'} &&
  &Apache::lonnet::get('environment',['screenname'],$udom,$uname);   $udom eq $env{'user.domain'}) {return $env{'environment.screenname'};}
       my %names=&Apache::lonnet::get('environment',['screenname'],$udom,$uname);
     return $names{'screenname'};      return $names{'screenname'};
 }  }
   
   
 # ------------------------------------------------------------- Message Wrapper  # ------------------------------------------------------------- Message Wrapper
   
 sub messagewrapper {  sub messagewrapper {
     my ($link,$un,$do)=@_;      my ($link,$username,$domain)=@_;
     return       return 
 "<a href='/adm/email?compose=individual&recname=$un&recdom=$do'>$link</a>";          '<a href="/adm/email?compose=individual&'.
           'recname='.$username.'&recdom='.$domain.'" '.
           'title="'.&mt('Send message').'">'.$link.'</a>';
 }  }
 # --------------------------------------------------------------- Notes Wrapper  # --------------------------------------------------------------- Notes Wrapper
   
Line 1800  sub noteswrapper { Line 2041  sub noteswrapper {
   
 sub aboutmewrapper {  sub aboutmewrapper {
     my ($link,$username,$domain,$target)=@_;      my ($link,$username,$domain,$target)=@_;
     return "<a href='/adm/$domain/$username/aboutme'".      return '<a href="/adm/'.$domain.'/'.$username.'/aboutme"'.
  ($target?" target='$target'":'').">$link</a>";   ($target?' target="$target"':'').' title="'.&mt('View this users personal page').'">'.$link.'</a>';
 }  }
   
 # ------------------------------------------------------------ Syllabus Wrapper  # ------------------------------------------------------------ Syllabus Wrapper
Line 1812  sub syllabuswrapper { Line 2053  sub syllabuswrapper {
     if ($fontcolor) {       if ($fontcolor) { 
         $linktext='<font color="'.$fontcolor.'">'.$linktext.'</font>';           $linktext='<font color="'.$fontcolor.'">'.$linktext.'</font>'; 
     }      }
     return "<a href='/public/$domain/$coursedir/syllabus'>$linktext</a>";      return qq{<a href="/public/$domain/$coursedir/syllabus">$linktext</a>};
   }
   
   sub track_student_link {
       my ($linktext,$sname,$sdom,$target,$start) = @_;
       my $link ="/adm/trackstudent?";
       my $title = 'View recent activity';
       if (defined($sname) && $sname !~ /^\s*$/ &&
           defined($sdom)  && $sdom  !~ /^\s*$/) {
           $link .= "selected_student=$sname:$sdom";
           $title .= ' of this student';
       } 
       if (defined($target) && $target !~ /^\s*$/) {
           $target = qq{target="$target"};
       } else {
           $target = '';
       }
       if ($start) { $link.='&amp;start='.$start; }
       return qq{<a href="$link" title="$title" $target>$linktext</a>};
 }  }
   
 =pod  =pod
Line 1928  category Line 2187  category
 =cut  =cut
   
 sub filecategorytypes {  sub filecategorytypes {
     return @{$category_extensions{lc($_[0])}};      my ($cat) = @_;
       return @{$category_extensions{lc($cat)}};
 }  }
   
 =pod  =pod
Line 1943  sub fileembstyle { Line 2203  sub fileembstyle {
     return $fe{lc(shift(@_))};      return $fe{lc(shift(@_))};
 }  }
   
   sub filemimetype {
       return $fm{lc(shift(@_))};
   }
   
   
 sub filecategoryselect {  sub filecategoryselect {
     my ($name,$value)=@_;      my ($name,$value)=@_;
Line 1999  sub fileextensions { Line 2263  sub fileextensions {
   
 sub display_languages {  sub display_languages {
     my %languages=();      my %languages=();
     foreach (&preferred_languages()) {      foreach my $lang (&preferred_languages()) {
  $languages{$_}=1;   $languages{$lang}=1;
     }      }
     &get_unprocessed_cgi($ENV{'QUERY_STRING'},['displaylanguage']);      &get_unprocessed_cgi($ENV{'QUERY_STRING'},['displaylanguage']);
     if ($ENV{'form.displaylanguage'}) {      if ($env{'form.displaylanguage'}) {
  foreach (split(/\s*(\,|\;|\:)\s*/,$ENV{'form.displaylanguage'})) {   foreach my $lang (split(/\s*(\,|\;|\:)\s*/,$env{'form.displaylanguage'})) {
     $languages{$_}=1;      $languages{$lang}=1;
         }          }
     }      }
     return %languages;      return %languages;
Line 2013  sub display_languages { Line 2277  sub display_languages {
   
 sub preferred_languages {  sub preferred_languages {
     my @languages=();      my @languages=();
     if ($ENV{'course.'.$ENV{'request.course.id'}.'.languages'}) {      if ($env{'course.'.$env{'request.course.id'}.'.languages'}) {
  @languages=(@languages,split(/\s*(\,|\;|\:)\s*/,   @languages=(@languages,split(/\s*(\,|\;|\:)\s*/,
          $ENV{'course.'.$ENV{'request.course.id'}.'.languages'}));           $env{'course.'.$env{'request.course.id'}.'.languages'}));
     }      }
     if ($ENV{'environment.languages'}) {      if ($env{'environment.languages'}) {
  @languages=split(/\s*(\,|\;|\:)\s*/,$ENV{'environment.languages'});   @languages=split(/\s*(\,|\;|\:)\s*/,$env{'environment.languages'});
     }      }
     my $browser=(split(/\;/,$ENV{'HTTP_ACCEPT_LANGUAGE'}))[0];      my $browser=(split(/\;/,$ENV{'HTTP_ACCEPT_LANGUAGE'}))[0];
     if ($browser) {      if ($browser) {
  @languages=(@languages,split(/\s*(\,|\;|\:)\s*/,$browser));   @languages=(@languages,split(/\s*(\,|\;|\:)\s*/,$browser));
     }      }
     if ($Apache::lonnet::domain_lang_def{$ENV{'user.domain'}}) {      if ($Apache::lonnet::domain_lang_def{$env{'user.domain'}}) {
  @languages=(@languages,   @languages=(@languages,
  $Apache::lonnet::domain_lang_def{$ENV{'user.domain'}});   $Apache::lonnet::domain_lang_def{$env{'user.domain'}});
     }      }
     if ($Apache::lonnet::domain_lang_def{$ENV{'request.role.domain'}}) {      if ($Apache::lonnet::domain_lang_def{$env{'request.role.domain'}}) {
  @languages=(@languages,   @languages=(@languages,
  $Apache::lonnet::domain_lang_def{$ENV{'request.role.domain'}});   $Apache::lonnet::domain_lang_def{$env{'request.role.domain'}});
     }      }
     if ($Apache::lonnet::domain_lang_def{      if ($Apache::lonnet::domain_lang_def{
                           $Apache::lonnet::perlvar{'lonDefDomain'}}) {                            $Apache::lonnet::perlvar{'lonDefDomain'}}) {
Line 2040  sub preferred_languages { Line 2304  sub preferred_languages {
     }      }
 # turn "en-ca" into "en-ca,en"  # turn "en-ca" into "en-ca,en"
     my @genlanguages;      my @genlanguages;
     foreach (@languages) {      foreach my $lang (@languages) {
  unless ($_=~/\w/) { next; }   unless ($lang=~/\w/) { next; }
  push (@genlanguages,$_);   push (@genlanguages,$lang);
  if ($_=~/(\-|\_)/) {   if ($lang=~/(\-|\_)/) {
     push (@genlanguages,(split(/(\-|\_)/,$_))[0]);      push(@genlanguages,(split(/(\-|\_)/,$lang))[0]);
  }   }
     }      }
     return @genlanguages;      return @genlanguages;
Line 2100  sub get_previous_attempt { Line 2364  sub get_previous_attempt {
       my %lasthash=();        my %lasthash=();
       my $version;        my $version;
       for ($version=1;$version<=$returnhash{'version'};$version++) {        for ($version=1;$version<=$returnhash{'version'};$version++) {
         foreach (sort(split(/\:/,$returnhash{$version.':keys'}))) {          foreach my $key (sort(split(/\:/,$returnhash{$version.':keys'}))) {
   $lasthash{$_}=$returnhash{$version.':'.$_};    $lasthash{$key}=$returnhash{$version.':'.$key};
         }          }
       }        }
       $prevattempts='<table border="0" width="100%"><tr><td bgcolor="#777777">';        $prevattempts='<table border="0" width="100%"><tr><td bgcolor="#777777">';
       $prevattempts.='<table border="0" width="100%"><tr bgcolor="#e6ffff"><td>History</td>';        $prevattempts.='<table border="0" width="100%"><tr bgcolor="#e6ffff"><td>History</td>';
       foreach (sort(keys %lasthash)) {        foreach my $key (sort(keys(%lasthash))) {
  my ($ign,@parts) = split(/\./,$_);   my ($ign,@parts) = split(/\./,$key);
  if ($#parts > 0) {   if ($#parts > 0) {
   my $data=$parts[-1];    my $data=$parts[-1];
   pop(@parts);    pop(@parts);
Line 2123  sub get_previous_attempt { Line 2387  sub get_previous_attempt {
       if ($getattempt eq '') {        if ($getattempt eq '') {
  for ($version=1;$version<=$returnhash{'version'};$version++) {   for ($version=1;$version<=$returnhash{'version'};$version++) {
   $prevattempts.='</tr><tr bgcolor="#ffffe6"><td>Transaction '.$version.'</td>';    $prevattempts.='</tr><tr bgcolor="#ffffe6"><td>Transaction '.$version.'</td>';
     foreach (sort(keys %lasthash)) {      foreach my $key (sort(keys(%lasthash))) {
        my $value;         my $value;
        if ($_ =~ /timestamp/) {         if ($key =~ /timestamp/) {
   $value=scalar(localtime($returnhash{$version.':'.$_}));    $value=scalar(localtime($returnhash{$version.':'.$key}));
        } else {         } else {
   $value=$returnhash{$version.':'.$_};    $value=$returnhash{$version.':'.$key};
        }         }
        $prevattempts.='<td>'.&Apache::lonnet::unescape($value).'&nbsp;</td>';            $prevattempts.='<td>'.&Apache::lonnet::unescape($value).'&nbsp;</td>';   
     }      }
  }   }
       }        }
       $prevattempts.='</tr><tr bgcolor="#ffffe6"><td>Current</td>';        $prevattempts.='</tr><tr bgcolor="#ffffe6"><td>Current</td>';
       foreach (sort(keys %lasthash)) {        foreach my $key (sort(keys(%lasthash))) {
  my $value;   my $value;
  if ($_ =~ /timestamp/) {   if ($key =~ /timestamp/) {
   $value=scalar(localtime($lasthash{$_}));    $value=scalar(localtime($lasthash{$key}));
  } else {   } else {
   $value=$lasthash{$_};    $value=$lasthash{$key};
  }   }
  $value=&Apache::lonnet::unescape($value);   $value=&Apache::lonnet::unescape($value);
  if ($_ =~/$regexp$/ && (defined &$gradesub)) {$value = &$gradesub($value)}   if ($key =~/$regexp$/ && (defined &$gradesub)) {$value = &$gradesub($value)}
  $prevattempts.='<td>'.$value.'&nbsp;</td>';   $prevattempts.='<td>'.$value.'&nbsp;</td>';
       }        }
       $prevattempts.='</tr></table></td></tr></table>';        $prevattempts.='</tr></table></td></tr></table>';
Line 2175  sub relative_to_absolute { Line 2439  sub relative_to_absolute {
  }   }
     }      }
     $thisdir=~s-/[^/]*$--;      $thisdir=~s-/[^/]*$--;
     foreach (@rlinks) {      foreach my $link (@rlinks) {
  unless (($_=~/^http:\/\//i) ||   unless (($link=~/^http:\/\//i) ||
  ($_=~/^\//) ||   ($link=~/^\//) ||
  ($_=~/^javascript:/i) ||   ($link=~/^javascript:/i) ||
  ($_=~/^mailto:/i) ||   ($link=~/^mailto:/i) ||
  ($_=~/^\#/)) {   ($link=~/^\#/)) {
     my $newlocation=&Apache::lonnet::hreflocation($thisdir,$_);      my $newlocation=&Apache::lonnet::hreflocation($thisdir,$link);
     $output=~s/(\"|\'|\=\s*)$_(\"|\'|\s|\>)/$1$newlocation$2/;      $output=~s/(\"|\'|\=\s*)\Q$link\E(\"|\'|\s|\>)/$1$newlocation$2/;
  }   }
     }      }
 # -------------------------------------------------- Deal with Applet codebases  # -------------------------------------------------- Deal with Applet codebases
Line 2209  sub get_student_view { Line 2473  sub get_student_view {
   if (defined($moreenv)) {    if (defined($moreenv)) {
       %form=(%form,%{$moreenv});        %form=(%form,%{$moreenv});
   }    }
   if ($target eq 'tex') {$form{'grade_target'} = 'tex';}    if (defined($target)) { $form{'grade_target'} = $target; }
   $feedurl=&Apache::lonnet::clutter($feedurl);    $feedurl=&Apache::lonnet::clutter($feedurl);
   my $userview=&Apache::lonnet::ssi_body($feedurl,%form);    my $userview=&Apache::lonnet::ssi_body($feedurl,%form);
   $userview=~s/\<body[^\>]*\>//gi;    $userview=~s/\<body[^\>]*\>//gi;
Line 2249  sub get_student_answers { Line 2513  sub get_student_answers {
   
 =item * &submlink()  =item * &submlink()
   
 Inputs: $text $uname $udom $symb  Inputs: $text $uname $udom $symb $target
   
 Returns: A link to grades.pm such as to see the SUBM view of a student  Returns: A link to grades.pm such as to see the SUBM view of a student
   
Line 2257  Returns: A link to grades.pm such as to Line 2521  Returns: A link to grades.pm such as to
   
 ###############################################  ###############################################
 sub submlink {  sub submlink {
     my ($text,$uname,$udom,$symb)=@_;      my ($text,$uname,$udom,$symb,$target)=@_;
       if (!($uname && $udom)) {
    (my $cursymb, my $courseid,$udom,$uname)=
       &Apache::lonxml::whichuser($symb);
    if (!$symb) { $symb=$cursymb; }
       }
       if (!$symb) { $symb=&Apache::lonnet::symbread(); }
       $symb=&Apache::lonnet::escape($symb);
       if ($target) { $target="target=\"$target\""; }
       return '<a href="/adm/grades?&command=submission&'.
    'symb='.$symb.'&student='.$uname.
    '&userdom='.$udom.'" '.$target.'>'.$text.'</a>';
   }
   ##############################################
   
   =pod
   
   =item * &pgrdlink()
   
   Inputs: $text $uname $udom $symb $target
   
   Returns: A link to grades.pm such as to see the PGRD view of a student
   
   =cut
   
   ###############################################
   sub pgrdlink {
       my $link=&submlink(@_);
       $link=~s/(&command=submission)/$1&showgrading=yes/;
       return $link;
   }
   ##############################################
   
   =pod
   
   =item * &pprmlink()
   
   Inputs: $text $uname $udom $symb $target
   
   Returns: A link to parmset.pm such as to see the PPRM view of a
   student and a specific resource
   
   =cut
   
   ###############################################
   sub pprmlink {
       my ($text,$uname,$udom,$symb,$target)=@_;
     if (!($uname && $udom)) {      if (!($uname && $udom)) {
  (my $cursymb, my $courseid,$udom,$uname)=   (my $cursymb, my $courseid,$udom,$uname)=
     &Apache::lonxml::whichuser($symb);      &Apache::lonxml::whichuser($symb);
  if (!$symb) { $symb=$cursymb; }   if (!$symb) { $symb=$cursymb; }
     }      }
     if (!$symb) { $symb=&symbread(); }      if (!$symb) { $symb=&Apache::lonnet::symbread(); }
     return '<a href="/adm/grades?symb='.$symb.'&student='.$uname.      $symb=&Apache::lonnet::escape($symb);
  '&userdom='.$udom.'&command=submission">'.$text.'</a>';      if ($target) { $target="target=\"$target\""; }
       return '<a href="/adm/parmset?&command=set&'.
    'symb='.$symb.'&uname='.$uname.
    '&udom='.$udom.'" '.$target.'>'.$text.'</a>';
 }  }
 ##############################################  ##############################################
   
Line 2295  sub maketime { Line 2608  sub maketime {
     my %th=@_;      my %th=@_;
     return POSIX::mktime(      return POSIX::mktime(
         ($th{'seconds'},$th{'minutes'},$th{'hours'},          ($th{'seconds'},$th{'minutes'},$th{'hours'},
          $th{'day'},$th{'month'}-1,$th{'year'}-1900,0,0,$th{'dlsav'}));           $th{'day'},$th{'month'}-1,$th{'year'}-1900,0,0,-1));
 }  }
   
 #########################################  #########################################
   
 sub findallcourses {  sub findallcourses {
     my %courses=();      my ($roles) = @_;
       my %roles;
       if (ref($roles)) { %roles = map { $_ => 1 } @{$roles}; }
       my %courses;
     my $now=time;      my $now=time;
     foreach (keys %ENV) {      foreach my $key (keys(%env)) {
  if ($_=~/^user\.role\.\w+\.\/(\w+)\/(\w+)/) {   if ( $key=~m{^user\.role\.(\w+)\./(\w+)/(\w+)} ) {
     my ($starttime,$endtime)=$ENV{$_};      my ($role,$domain,$id) = ($1,$2,$3);
       next if ($role eq 'ca' || $role eq 'aa');
       next if (%roles && !exists($roles{$role}));
       my ($starttime,$endtime)=split(/\./,$env{$key});
             my $active=1;              my $active=1;
             if ($starttime) {              if ($starttime) {
  if ($now<$starttime) { $active=0; }   if ($now<$starttime) { $active=0; }
Line 2313  sub findallcourses { Line 2632  sub findallcourses {
             if ($endtime) {              if ($endtime) {
                 if ($now>$endtime) { $active=0; }                  if ($now>$endtime) { $active=0; }
             }              }
             if ($active) { $courses{$1.'_'.$2}=1; }              if ($active) { $courses{$domain.'_'.$id}=1; }
         }          }
     }      }
     return keys %courses;      return keys(%courses);
 }  }
   
 ###############################################  ###############################################
Line 2342  sub determinedomain { Line 2661  sub determinedomain {
    if (! $domain) {     if (! $domain) {
         # Determine domain if we have not been given one          # Determine domain if we have not been given one
         $domain = $Apache::lonnet::perlvar{'lonDefDomain'};          $domain = $Apache::lonnet::perlvar{'lonDefDomain'};
         if ($ENV{'user.domain'}) { $domain=$ENV{'user.domain'}; }          if ($env{'user.domain'}) { $domain=$env{'user.domain'}; }
         if ($ENV{'request.role.domain'}) {           if ($env{'request.role.domain'}) { 
             $domain=$ENV{'request.role.domain'};               $domain=$env{'request.role.domain'}; 
         }          }
     }      }
     return $domain;      return $domain;
Line 2366  sub domainlogo { Line 2685  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') {
  my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'};   my $logo=&lonhttpdurl("/adm/lonDomLogos/$domain.gif");
  if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; }          return '<img src="'.$logo.'" alt="'.$domain.'" />';
         return '<img src="http://'.$ENV{'HTTP_HOST'}.':'.$lonhttpdPort.  
     '/adm/lonDomLogos/'.$domain.'.gif" alt="'.$domain.'" />';  
     } 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 2391  Returns: value of designparamter $which Line 2708  Returns: value of designparamter $which
 ##############################################  ##############################################
 sub designparm {  sub designparm {
     my ($which,$domain)=@_;      my ($which,$domain)=@_;
     if ($ENV{'browser.blackwhite'} eq 'on') {      if ($env{'browser.blackwhite'} eq 'on') {
  if ($which=~/\.(font|alink|vlink|link)$/) {   if ($which=~/\.(font|alink|vlink|link)$/) {
     return '#000000';      return '#000000';
  }   }
Line 2402  sub designparm { Line 2719  sub designparm {
     return '#CCCCCC';      return '#CCCCCC';
  }   }
     }      }
     if ($ENV{'environment.color.'.$which}) {      if ($env{'environment.color.'.$which}) {
  return $ENV{'environment.color.'.$which};   return $env{'environment.color.'.$which};
     }      }
     $domain=&determinedomain($domain);      $domain=&determinedomain($domain);
     if ($designhash{$domain.'.'.$which}) {      if ($designhash{$domain.'.'.$which}) {
Line 2445  Inputs: Line 2762  Inputs:
 =item * $forcereg, if page should register as content page (relevant for   =item * $forcereg, if page should register as content page (relevant for 
             text interface only)              text interface only)
   
   =item * $customtitle, alternate text to use instead of $title
                         in the title box that appears, this text
                         is not auto translated like the $title is
   
   =item * $notopbar, if true, keep the 'what is this' info but remove the
                      navigational links
   
   =item * $bgcolor, used to override the bgcolor on a webpage to a specific value
   
   =item * $notitle, if true keep the nav controls, but remove the title bar
   
   
 =back  =back
   
 Returns: A uniform header for LON-CAPA web pages.    Returns: A uniform header for LON-CAPA web pages.  
Line 2455  other decorations will be returned. Line 2784  other decorations will be returned.
 =cut  =cut
   
 sub bodytag {  sub bodytag {
     my ($title,$function,$addentries,$bodyonly,$domain,$forcereg)=@_;      my ($title,$function,$addentries,$bodyonly,$domain,$forcereg,$customtitle,
    $notopbar,$bgcolor,$notitle)=@_;
   
     $title=&mt($title);      $title=&mt($title);
   
     $function = &get_users_function() if (!$function);      $function = &get_users_function() if (!$function);
     my $img=&designparm($function.'.img',$domain);      my $img =    &designparm($function.'.img',$domain);
     my $pgbg=&designparm($function.'.pgbg',$domain);      my $tabbg =  &designparm($function.'.tabbg',$domain);
     my $tabbg=&designparm($function.'.tabbg',$domain);      my $font =   &designparm($function.'.font',$domain);
     my $font=&designparm($function.'.font',$domain);      my $sidebg = &designparm($function.'.sidebg',$domain);
     my $link=&designparm($function.'.link',$domain);      my $pgbg   = $bgcolor || &designparm($function.'.pgbg',$domain);
     my $alink=&designparm($function.'.alink',$domain);  
     my $vlink=&designparm($function.'.vlink',$domain);      my %design = ( 'style'   => 'margin-top: 0px',
     my $sidebg=&designparm($function.'.sidebg',$domain);     'bgcolor' => $pgbg,
 # Accessibility font enhance     'text'    => $font,
     unless ($addentries) { $addentries=''; }                     'alink'   => &designparm($function.'.alink',$domain),
     my $addstyle='';     'vlink'   => &designparm($function.'.vlink',$domain),
     if ($ENV{'browser.fontenhance'} eq 'on') {     'link'    => &designparm($function.'.link',$domain),);
  $addstyle=' font-size: x-large;';      @$addentries{keys(%design)} = @design{keys(%design)};
     }  
  # role and realm   # 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
     if ($ENV{'request.course.id'}) {      if ($env{'request.course.id'}) {
  $realm=   $realm=
          $ENV{'course.'.$ENV{'request.course.id'}.'.description'};           $env{'course.'.$env{'request.course.id'}.'.description'};
     }      }
     unless ($realm) { $realm='&nbsp;'; }      unless ($realm) { $realm='&nbsp;'; }
 # Set messages  # Set messages
Line 2486  sub bodytag { Line 2818  sub bodytag {
 # Port for miniserver  # Port for miniserver
     my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'};      my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'};
     if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; }      if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; }
   
       my $extra_body_attr = &make_attr_string($forcereg,$addentries);
   
 # construct main body tag  # construct main body tag
     my $bodytag = <<END;      my $bodytag = <<END;
 <style>  <body $extra_body_attr>
 h1, h2, h3, th { font-family: Arial, Helvetica, sans-serif }  
 a:focus { color: red; background: yellow }   
 </style>  
 <body bgcolor="$pgbg" text="$font" alink="$alink" vlink="$vlink" link="$link"  
 style="margin-top: 0px;$addstyle" $addentries>  
 END  END
   
       $bodytag .= &Apache::lontexconvert::init_math_support();
   
     my $upperleft='<img src="http://'.$ENV{'HTTP_HOST'}.':'.      my $upperleft='<img src="http://'.$ENV{'HTTP_HOST'}.':'.
                    $lonhttpdPort.$img.'" alt="'.$function.'" />';                     $lonhttpdPort.$img.'" alt="'.$function.'" />';
     if ($bodyonly) {      if ($bodyonly 
    || ($env{'request.state'} eq 'construct' 
       && $env{'environment.remote'} ne 'off' )) {
         return $bodytag;          return $bodytag;
     } elsif ($ENV{'browser.interface'} eq 'textual') {      } elsif ($env{'browser.interface'} eq 'textual') {
 # Accessibility  # Accessibility
         return $bodytag.&Apache::lonmenu::menubuttons($forcereg,'web',            
                                                       $forcereg).   $bodytag.=&Apache::lonmenu::menubuttons($forcereg,$forcereg);
                '<h1>LON-CAPA: '.$title.'</h1>';   if (!$notitle) {
     } elsif ($ENV{'environment.remote'} eq 'off') {      $bodytag.='<h1>LON-CAPA: '.$title.'</h1>';
    }
    return $bodytag;
       } elsif ($env{'environment.remote'} eq 'off') {
 # No Remote  # No Remote
         return $bodytag.&Apache::lonmenu::menubuttons($forcereg,'web',   my $roleinfo=(<<ENDROLE);
                                                       $forcereg).  <td bgcolor="$tabbg" align="right">
       '<table bgcolor="'.$pgbg.'" width="100%" border="0" cellspacing="3" cellpadding="3"><tr><td bgcolor="'.$tabbg.'"><font face="Arial, Helvetica, sans-serif" size="+3" color="'.$font.'"><b>'.$title.  <font size="2" face="Arial, Helvetica, sans-serif">
 '</b></font></td></tr></table>';      $env{'environment.firstname'}
       $env{'environment.middlename'}
       $env{'environment.lastname'}
       $env{'environment.generation'}
       </font>&nbsp;
   <br />
   <font size="2" face="Arial, Helvetica, sans-serif">$role</font>&nbsp;
   <br />
   <font size="2" face="Arial, Helvetica, sans-serif">$realm</font>&nbsp;
   </td>
   ENDROLE
           my $titleinfo = '<font face="Arial, Helvetica, sans-serif" size="+3" color="'.
    $font.'"><b>'.$title.'</b></font>';
           if ($customtitle) {
               $titleinfo = $customtitle;
           }
   
    if ($env{'request.state'} eq 'construct') {
       my ($uname,$thisdisfn)=
    ($env{'request.filename'} =~ m|^/home/([^/]+)/public_html/(.*)|);
       my $formaction='/priv/'.$uname.'/'.$thisdisfn;
       $formaction=~s/\/+/\//g;
               unless ($customtitle) {  #this is for resources; directories have customtitle, and crumbs and select recent are created in lonpubdir.pm  
                   my $parentpath = '';
                   my $lastitem = '';
                   if ($thisdisfn =~ m-(.+/)([^/]*)$-) {
                       $parentpath = $1;
                       $lastitem = $2;
                   } else {
                       $lastitem = $thisdisfn;
                   }
           $titleinfo = &Apache::loncommon::help_open_menu('','','','',3,'Authoring').
                         '<font face="Arial, Helvetica, sans-serif"><b>Construction Space</b>:</font>&nbsp;'. 
                         '<form name="dirs" method="post" action="'.$formaction
       .'" target="_top"><tt><b>'
       .&Apache::lonhtmlcommon::crumbs($uname.'/'.$parentpath,'_top','/priv','','+1',1)."<font size=\"+1\">$lastitem</font></b></tt><br />"
       .&Apache::lonhtmlcommon::select_recent('construct','recent','this.form.action=this.form.recent.value;this.form.submit()')
       .'</form>'
       .&Apache::lonmenu::constspaceform();
   
               }
       $forcereg=1;
           }
           my $titletable;
    if (!$notitle) {
       $titletable =
    '<table bgcolor="'.$pgbg.'" width="100%" border="0" '.
                            'cellspacing="3" cellpadding="3">'.
                            '<tr><td bgcolor="'.$tabbg.'">'.
                            $titleinfo.'</td>'.$roleinfo.'</tr></table>';
    }
    if ($env{'request.state'} eq 'construct') {
               if ($notopbar) {
                   $bodytag .= $titletable;
               } else {
                   $bodytag .= &Apache::lonmenu::menubuttons($forcereg,$forcereg,
     $titletable);
               }
    } else {
               if ($notopbar) {
                   $bodytag .= $titletable;
               } else {
                   $bodytag .= &Apache::lonmenu::menubuttons($forcereg,$forcereg).
                           $titletable;
               }
           }
           return $bodytag;
     }      }
   
 #  #
 # Top frame rendering, Remote is up  # Top frame rendering, Remote is up
 #  #
       my $titleinfo = '&nbsp;<font size="5" face="Arial, Helvetica, sans-serif"><b>'.$title.'</b></font>';
       if ($customtitle) {
           $titleinfo = $customtitle;
       }
       #
       # Extra info if you are the DC
       my $dc_info = '';
       if ($env{'user.adv'} && exists($env{'user.role.dc./'.
                           $env{'course.'.$env{'request.course.id'}.
                                    '.domain'}.'/'})) {
           my $cid = $env{'request.course.id'};
           $dc_info.= $cid.' '.$env{'course.'.$cid.'.internal.coursecode'};
           $dc_info = '('.$dc_info.')';
       }
       # Explicit link to get inline menu
       my $menu='<br /><font size="2" face="Arial, Helvetica, sans-serif">&nbsp;<a href="/adm/remote?action=collapse">'.&mt('Switch to Inline Menu Mode').'</a></font>';
       #
       if ($notitle) {
    return $bodytag;
       }
     return(<<ENDBODY);      return(<<ENDBODY);
 $bodytag  $bodytag
 <table width="100%" cellspacing="0" border="0" cellpadding="0">  <table width="100%" cellspacing="0" border="0" cellpadding="0">
Line 2524  $upperleft</td> Line 2948  $upperleft</td>
 </tr>  </tr>
 <tr>  <tr>
 <td rowspan="3" bgcolor="$tabbg">  <td rowspan="3" bgcolor="$tabbg">
 &nbsp;<font size="5" face="Arial, Helvetica, sans-serif"><b>$title</b></font>  $titleinfo $dc_info $menu
 <td bgcolor="$tabbg" align="right">  </td><td bgcolor="$tabbg" align="right">
 <font size="2" face="Arial, Helvetica, sans-serif">  <font size="2" face="Arial, Helvetica, sans-serif">
     $ENV{'environment.firstname'}      $env{'environment.firstname'}
     $ENV{'environment.middlename'}      $env{'environment.middlename'}
     $ENV{'environment.lastname'}      $env{'environment.lastname'}
     $ENV{'environment.generation'}      $env{'environment.generation'}
     </font>&nbsp;      </font>&nbsp;
 </td>  </td>
 </tr>  </tr>
Line 2539  $upperleft</td> Line 2963  $upperleft</td>
 </td></tr>  </td></tr>
 <tr>  <tr>
 <td bgcolor="$tabbg" align="right"><font size="2" face="Arial, Helvetica, sans-serif">$realm</font>&nbsp;</td></tr>  <td bgcolor="$tabbg" align="right"><font size="2" face="Arial, Helvetica, sans-serif">$realm</font>&nbsp;</td></tr>
 </table><br>  </table>
 ENDBODY  ENDBODY
 }  }
   
   sub make_attr_string {
       my ($register,$attr_ref) = @_;
   
       if ($attr_ref && !ref($attr_ref)) {
    die("addentries Must be a hash ref ".
       join(':',caller(1))." ".
       join(':',caller(0))." ");
       }
   
       if ($register) {
    my ($on_load,$on_unload);
    foreach my $key (keys(%{$attr_ref})) {
       if      (lc($key) eq 'onload') {
    $on_load.=$attr_ref->{$key}.';';
    delete($attr_ref->{$key});
   
       } elsif (lc($key) eq 'onunload') {
    $on_unload.=$attr_ref->{$key}.';';
    delete($attr_ref->{$key});
       }
    }
    $attr_ref->{'onload'}  =
       &Apache::lonmenu::loadevents().  $on_load;
    $attr_ref->{'onunload'}=
       &Apache::lonmenu::unloadevents().$on_unload;
       }
   
   # Accessibility font enhance
       if ($env{'browser.fontenhance'} eq 'on') {
    my $style;
    foreach my $key (keys(%{$attr_ref})) {
       if (lc($key) eq 'style') {
    $style.=$attr_ref->{$key}.';';
    delete($attr_ref->{$key});
       }
    }
    $attr_ref->{'style'}=$style.'; font-size: x-large;';
       }
   
       if ($env{'browser.blackwhite'} eq 'on') {
    delete($attr_ref->{'font'});
    delete($attr_ref->{'link'});
    delete($attr_ref->{'alink'});
    delete($attr_ref->{'vlink'});
    delete($attr_ref->{'bgcolor'});
    delete($attr_ref->{'background'});
       }
   
       my $attr_string;
       foreach my $attr (keys(%$attr_ref)) {
    $attr_string .= " $attr=\"".$attr_ref->{$attr}.'" ';
       }
       return $attr_string;
   }
   
   
   ###############################################
 ###############################################  ###############################################
   
 =pod  =pod
   
   =back
   
   =head1 HTML Helpers
   
   =over 4
   
   =item * &endbodytag()
   
   Returns a uniform footer for LON-CAPA web pages.
   
   Inputs: none
   
   =back
   
   =cut
   
   sub endbodytag {
       my $endbodytag='</body>';
       $endbodytag=&Apache::lontexconvert::jsMath_process()."\n".$endbodytag;
       if ( exists( $env{'internal.head.redirect'} ) ) {
    $endbodytag=
       "<br /><a href=\"$env{'internal.head.redirect'}\">".
       &mt('Continue').'</a>'.
       $endbodytag;
       }
       return $endbodytag;
   }
   
   =pod
   
   =over 4
   
   =item * &standard_css()
   
   Returns a style sheet
   
   Inputs: (all optional)
               domain         -> force to color decorate a page for a specific
                                  domain
               function       -> force usage of a specific rolish color scheme
               bgcolor        -> override the default page bgcolor
   
   =back
   
   =cut
   
   sub standard_css {
       my ($function,$domain,$bgcolor) = @_;
       $function  = &get_users_function() if (!$function);
       my $img    = &designparm($function.'.img',   $domain);
       my $tabbg  = &designparm($function.'.tabbg', $domain);
       my $font   = &designparm($function.'.font',  $domain);
       my $sidebg = &designparm($function.'.sidebg',$domain);
       my $pgbg   = $bgcolor ||
            &designparm($function.'.pgbg',  $domain);
       my $alink  = &designparm($function.'.alink', $domain);
       my $vlink  = &designparm($function.'.vlink', $domain);
       my $link   = &designparm($function.'.link',  $domain);
   
       my $sans                 = 'Arial,Helvetica,sans-serif';
       my $data_table_head      = $tabbg;
       my $data_table_light     = '#EEEEEE';
       my $data_table_dark      = '#DDD';
       my $data_table_highlight = '#FFFF00';
       my $mail_new             = '#FFBB77';
       my $mail_new_hover       = '#DD9955';
       my $mail_read            = '#BBBB77';
       my $mail_read_hover      = '#999944';
       my $mail_replied         = '#AAAA88';
       my $mail_replied_hover   = '#888855';
       my $mail_other           = '#99BBBB';
       my $mail_other_hover     = '#669999';
   
       return <<END;
   <style type="text/css">
   h1, h2, h3, th { font-family: $sans }
   a:focus { color: red; background: yellow } 
   table.thinborder { border-collapse: collapse; }
   table.thinborder tr th, table.thinborder tr td { border-style: solid; border-width: 1px}
   form, .inline { display: inline; }
   .center { text-align: center; }
   .filename {font-family: monospace;}
   .LC_error {
     color: red;
     font-size: larger;
   }
   .LC_success {
     color: green;
   }
   
   table#LC_top_nav, table#LC_menubuttons, table#LC_nav_location, table#LC_breadcrumbs {
     width: 100%;
     background: $pgbg;
     border: 0px;
     border-spacing: 1px;
     padding: 0px;
     margin: 0px;
     border-collapse: separate;
   }
   table#LC_menubuttons_mainmenu {
     background: $pgbg;
     border: 0px;
     border-spacing: 1px;
     padding: 0px;
     margin: 0px;
     border-collapse: separate;
   }
   table#LC_menubuttons img, table#LC_menubuttons_mainmenu img {
     border: 0px;
   }
   table#LC_top_nav td {
     background: $tabbg;
   }
   table#LC_top_nav td a, div#LC_top_nav a {
     color: $font;
     font-family: $sans;
   }
   table#LC_breadcrumbs td {
     background: $tabbg;
     color: $font;
     font-family: $sans;
     font-size: smaller;
   }
   table#LC_breadcrumbs td.LC_breadcrumb_component {
     background: $tabbg;
     color: $font;
     font-family: $sans;
     font-size: larger;
     text-align: right;
   }
   .LC_menubuttons_inline_text {
     color: $font;
     font-family: $sans;
     font-size: smaller;
   }
   
   td.LC_menubuttons_text {
     color: $font;
     font-family: $sans;
   }
   td.LC_menubuttons_img {
     background: $tabbg;
   }
   .LC_current_location {
     font-family: $sans;
     background: $tabbg;
   }
   .LC_new_mail {
     font-family: $sans;
     font-weight: bold;
   }
   
   table.LC_data_table, table.LC_mail_list {
     border: 1px solid #000000;
     border-collapse: seperate;
   }
   table.LC_data_table tr th, table.LC_calendar tr th, table.LC_mail_list tr th {
     font-weight: bold;
     background-color: $data_table_head;
   }
   table.LC_data_table tr td {
     background-color: $data_table_light;
   }
   table.LC_data_table tr.LC_even_row td {
     background-color: $data_table_dark;
   }
   table.LC_data_table tr.LC_empty td {
     background-color: #FFFFFF;
   }
   
   table.LC_calendar {
     border: 1px solid #000000;
     border-collapse: collapse;
   }
   table.LC_calendar_pickdate {
     font-size: xx-small;
   }
   table.LC_calendar tr td {
     border: 1px solid #000000;
     vertical-align: top;
   }
   table.LC_calendar tr td.LC_calendar_day_empty {
     background-color: $data_table_dark;
   }
   table.LC_calendar tr td.LC_calendar_day_current {
     background-color: $data_table_highlight;
   }
   
   table.LC_mail_list tr.LC_mail_new {
     background-color: $mail_new;
   }
   table.LC_mail_list tr.LC_mail_new:hover {
     background-color: $mail_new_hover;
   }
   table.LC_mail_list tr.LC_mail_read {
     background-color: $mail_read;
   }
   table.LC_mail_list tr.LC_mail_read:hover {
     background-color: $mail_read_hover;
   }
   table.LC_mail_list tr.LC_mail_replied {
     background-color: $mail_replied;
   }
   table.LC_mail_list tr.LC_mail_replied:hover {
     background-color: $mail_replied_hover;
   }
   table.LC_mail_list tr.LC_mail_other {
     background-color: $mail_other;
   }
   table.LC_mail_list tr.LC_mail_other:hover {
     background-color: $mail_other_hover;
   }
   </style>
   END
   }
   
   =pod
   
   =over 4
   
   =item * &headtag()
   
   Returns a uniform footer for LON-CAPA web pages.
   
   Inputs: $title - optional title for the head
           $head_extra - optional extra HTML to put inside the <head>
           $args - optional arguments
               force_register - if is true call registerurl so the remote is 
                                informed
               redirect       -> array ref of seconds before redirect occurs
                                       url to redirect to
                              (side effect of setting 
                                  $env{'internal.head.redirect'} to the url 
                                  redirected too)
               domain         -> force to color decorate a page for a specific
                                  domain
               function       -> force usage of a specific rolish color scheme
               bgcolor        -> override the default page bgcolor
   
   =back
   
   =cut
   
   sub headtag {
       my ($title,$head_extra,$args) = @_;
       
       my $result =
    '<head>'.
    &standard_css($args->{'function'},$args->{'domain'},
         $args->{'bgcolor'}).
    &font_settings().
    &Apache::lonhtmlcommon::htmlareaheaders();
   
       if ($args->{'force_register'}) {
    $result .= &Apache::lonmenu::registerurl(1);
       }
   
       if (ref($args->{'redirect'})) {
    my ($time,$url) = @{$args->{'redirect'}};
    $url = &Apache::lonenc::check_encrypt($url);
    $env{'internal.head.redirect'} = $url;
    $result.=<<ADDMETA
   <meta http-equiv="pragma" content="no-cache" />
   <meta http-equiv="Refresh" content="$time; url=$url" />
   ADDMETA
       }
       if (!defined($title)) {
    $title = 'The LearningOnline Network with CAPA';
       }
       
       $result .= '<title> LON-CAPA '.&mt($title).'</title>'.$head_extra;
       return $result;
   }
   
   =pod
   
   =over 4
   
   =item * &font_settings()
   
   Returns neccessary <meta> to set the proper encoding
   
   Inputs: none
   
   =back
   
   =cut
   
   sub font_settings {
       my $headerstring='';
       if (($env{'browser.os'} eq 'mac') && (!$env{'browser.mathml'})) { 
    $headerstring.=
       '<meta Content-Type="text/html; charset=x-mac-roman" />';
       } elsif (!$env{'browser.mathml'} && $env{'browser.unicode'}) {
    $headerstring.=
       '<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />';
       }
       return $headerstring;
   }
   
   =pod
   
   =over 4
   
   =item * &xml_begin()
   
   Returns the needed doctype and <html>
   
   Inputs: none
   
   =back
   
   =cut
   
   sub xml_begin {
       my $output='';
   
       &Apache::lonhtmlcommon::init_htmlareafields();
   
       if ($env{'browser.mathml'}) {
    $output='<?xml version="1.0"?>'
               #.'<?xml-stylesheet type="text/css" href="/adm/MathML/mathml.css"?>'."\n"
   #            .'<!DOCTYPE html SYSTEM "/adm/MathML/mathml.dtd" '
               
   #    .'<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd" [<!ENTITY mathns "http://www.w3.org/1998/Math/MathML">] >'
       .'<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1 plus MathML 2.0 plus SVG 1.1//EN" "http://www.w3.org/2002/04/xhtml-math-svg/xhtml-math-svg.dtd">'
               .'<html xmlns:math="http://www.w3.org/1998/Math/MathML" ' 
       .'xmlns="http://www.w3.org/1999/xhtml">';
       } else {
    $output='<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"><html>';
       }
       return $output;
   }
   
   =pod
   
   =over 4
   
   =item * &endheadtag()
   
   Returns a uniform </head> for LON-CAPA web pages.
   
   Inputs: none
   
   =back
   
   =cut
   
   sub endheadtag {
       return '</head>';
   }
   
   =pod
   
   =over 4
   
   =item * &head()
   
   Returns a uniform complete <head>..</head> section for LON-CAPA web pages.
   
   Inputs: $title - optional title for the page
           $head_extra - optional extra HTML to put inside the <head>
   =back
   
   =cut
   
   sub head {
       my ($title,$head_extra,$args) = @_;
       return &headtag($title,$head_extra,$args).&endheadtag();
   }
   
   =pod
   
   =over 4
   
   =item * &start_page()
   
   Returns a complete <html> .. <body> section for LON-CAPA web pages.
   
   Inputs: $title - optional title for the page
           $head_extra - optional extra HTML to incude inside the <head>
           $args - additional optional args supported are:
                     only_body      -> is true will set &bodytag() onlybodytag
                                       arg on
                     no_nav_bar     -> is true will set &bodytag() notopbar arg on
                     add_entries    -> additional attributes to add to the  <body>
                     domain         -> force to color decorate a page for a 
                                       specific domain
                     function       -> force usage of a specific rolish color
                                       scheme
                     redirect       -> see &headtag()
                     bgcolor        -> override the default page bg color
                     js_ready       -> return a string ready for being used in 
                                       a javascript writeln
                     html_encode    -> return a string ready for being used in 
                                       a html attribute
                     force_register -> if is true will turn on the &bodytag()
                                       $forcereg arg
                     body_title     -> alternate text to use instead of $title
                                       in the title box that appears, this text
                                       is not auto translated like the $title is
                     frameset       -> if true will start with a <frameset>
                                       rather than <body>
                     no_title       -> if true the title bar won't be shown
                     skip_phases    -> hash ref of 
                                       head -> skip the <html><head> generation
                                       body -> skip all <body> generation
   
   =back
   
   =cut
   
   sub start_page {
       my ($title,$head_extra,$args) = @_;
       #&Apache::lonnet::logthis("start_page ".join(':',caller(0)));
       my %head_args;
       foreach my $arg ('redirect','force_register','domain','function',
        'bgcolor') {
    if (defined($args->{$arg})) {
       $head_args{$arg} = $args->{$arg};
    }
       }
   
       $env{'internal.start_page'}++;
       my $result;
       if (! exists($args->{'skip_phases'}{'head'}) ) {
    $result.=
       &xml_begin().
       &headtag($title,$head_extra,\%head_args).&endheadtag();
       }
       
       if (! exists($args->{'skip_phases'}{'body'}) ) {
    if ($args->{'frameset'}) {
       my $attr_string = &make_attr_string($args->{'force_register'},
    $args->{'add_entries'});
       $result .= "\n<frameset $attr_string>\n";
    } else {
       $result .=
    &bodytag($title, 
    $args->{'function'},       $args->{'add_entries'},
    $args->{'only_body'},      $args->{'domain'},
    $args->{'force_register'}, $args->{'body_title'},
    $args->{'no_nav_bar'},     $args->{'bgcolor'},
    $args->{'no_title'});
    }
       }
   
       if ($args->{'js_ready'}) {
    $result = &js_ready($result);
       }
       if ($args->{'html_encode'}) {
    $result = &html_encode($result);
       }
       return $result;
   }
   
   
   =pod
   
   =over 4
   
   =item * &head()
   
   Returns a complete </body></html> section for LON-CAPA web pages.
   
   Inputs:         $args - additional optional args supported are:
                    js_ready     -> return a string ready for being used in 
                                    a javascript writeln
                    html_encode  -> return a string ready for being used in 
                                    a html attribute
                    frameset     -> if true will start with a <frameset>
                                    rather than <body>
   =back
   
   =cut
   
   sub end_page {
       my ($args) = @_;
       #&Apache::lonnet::logthis("end_page ".join(':',caller(0)));
       $env{'internal.end_page'}++;
       my $result;
       if ($args->{'discussion'}) {
    my ($target,$parser);
    if (ref($args->{'discussion'})) {
       ($target,$parser) =($args->{'discussion'}{'target'},
    $args->{'discussion'}{'parser'});
    }
    $result .= &Apache::lonxml::xmlend($target,$parser);
       }
   
       if ($args->{'frameset'}) {
    $result .= '</frameset>';
       } else {
    $result .= &endbodytag();
       }
       $result .= "\n</html>";
   
       if ($args->{'js_ready'}) {
    $result = &js_ready($result);
       }
   
       if ($args->{'html_encode'}) {
    $result = &html_encode($result);
       }
   
       return $result;
   }
   
   sub html_encode {
       my ($result) = @_;
   
       $result = &HTML::Entities::encode($result,'<>&"');
       
       return $result;
   }
   sub js_ready {
       my ($result) = @_;
   
       $result =~ s/[\n\r]/ /xmsg;
       $result =~ s/\\/\\\\/xmsg;
       $result =~ s/'/\\'/xmsg;
       $result =~ s{</script>}{</scrip'+'t>}xmsg;
       
       return $result;
   }
   
   sub validate_page {
       if (  exists($env{'internal.start_page'})
     &&     $env{'internal.start_page'} > 1) {
    &Apache::lonnet::logthis('start_page called multiple times '.
    $env{'internal.start_page'}.' '.
    $ENV{'request.filename'});
       }
       if (  exists($env{'internal.end_page'})
     &&     $env{'internal.end_page'} > 1) {
    &Apache::lonnet::logthis('end_page called multiple times '.
    $env{'internal.end_page'}.' '.
    $env{'request.filename'});
       }
       if (     exists($env{'internal.start_page'})
    && ! exists($env{'internal.end_page'})) {
    &Apache::lonnet::logthis('start_page called without end_page '.
    $env{'request.filename'});
       }
       if (   ! exists($env{'internal.start_page'})
    &&   exists($env{'internal.end_page'})) {
    &Apache::lonnet::logthis('end_page called without start_page'.
    $env{'request.filename'});
       }
   }
   
   sub simple_error_page {
       my ($r,$title,$msg) = @_;
       my $page =
    &Apache::loncommon::start_page($title).
    &mt($msg).
    &Apache::loncommon::end_page();
       if (ref($r)) {
    $r->print($page);
    return;
       }
       return $page;
   }
   
   {
       my $row_count;
       sub start_data_table {
    undef($row_count);
    return '<table class="LC_data_table">';
       }
   
       sub end_data_table {
    undef($row_count);
    return '</table>';
       }
   
       sub start_data_table_row {
    $row_count++;
    return  '<tr '.(($row_count % 2)?'':'class="LC_even_row"').'>';
       }
   
       sub end_data_table_row {
    return '</tr>';
       }
   }
   
   ###############################################
   
   =pod
   
   =over 4
   
 =item get_users_function  =item get_users_function
   
 Used by &bodytag to determine the current users primary role.  Used by &bodytag to determine the current users primary role.
Line 2557  Returns either 'student','coordinator',' Line 3630  Returns either 'student','coordinator','
 ###############################################  ###############################################
 sub get_users_function {  sub get_users_function {
     my $function = 'student';      my $function = 'student';
     if ($ENV{'request.role'}=~/^(cc|in|ta|ep)/) {      if ($env{'request.role'}=~/^(cc|in|ta|ep)/) {
         $function='coordinator';          $function='coordinator';
     }      }
     if ($ENV{'request.role'}=~/^(su|dc|ad|li)/) {      if ($env{'request.role'}=~/^(su|dc|ad|li)/) {
         $function='admin';          $function='admin';
     }      }
     if (($ENV{'request.role'}=~/^(au|ca)/) ||      if (($env{'request.role'}=~/^(au|ca)/) ||
         ($ENV{'REQUEST_URI'}=~/^(\/priv|\~)/)) {          ($ENV{'REQUEST_URI'}=~/^(\/priv|\~)/)) {
         $function='author';          $function='author';
     }      }
Line 2572  sub get_users_function { Line 3645  sub get_users_function {
   
 ###############################################  ###############################################
   
 sub get_posted_cgi {  =pod
     my $r=shift;  
   
     my $buffer;  =item check_user_status
       
     $r->read($buffer,$r->header_in('Content-length'),0);  Determines current status of supplied role for a
     unless ($buffer=~/^(\-+\w+)\s+Content\-Disposition\:\s*form\-data/si) {  specific user. Roles can be active, previous or future.
  my @pairs=split(/&/,$buffer);  
  my $pair;  Inputs: 
  foreach $pair (@pairs) {  user's domain, user's username, course's domain,
     my ($name,$value) = split(/=/,$pair);  course's number, optional section/group.
     $value =~ tr/+/ /;  
     $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;  Outputs:
     $name  =~ tr/+/ /;  role status: active, previous or future. 
     $name  =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;  
     &add_to_env("form.$name",$value);  =cut
  }  
     } else {  sub check_user_status {
  my $contentsep=$1;      my ($udom,$uname,$cdom,$crs,$role,$secgrp) = @_;
  my @lines = split (/\n/,$buffer);      my %userinfo = &Apache::lonnet::dump('roles',$udom,$uname);
  my $name='';      my @uroles = keys %userinfo;
  my $value='';      my $srchstr;
  my $fname='';      my $active_chk = 'none';
  my $fmime='';      if (@uroles > 0) {
  my $i;          if (($role eq 'cc') || ($secgrp eq '') || (!defined($secgrp))) {
  for ($i=0;$i<=$#lines;$i++) {              $srchstr = '/'.$cdom.'/'.$crs.'_'.$role;
     if ($lines[$i]=~/^$contentsep/) {          } else {
  if ($name) {              $srchstr = '/'.$cdom.'/'.$crs.'/'.$secgrp.'_'.$role;         }
     chomp($value);          if (grep/^$srchstr$/,@uroles) {
     if ($fname) {              my $role_end = 0;
  $ENV{"form.$name.filename"}=$fname;              my $role_start = 0;
  $ENV{"form.$name.mimetype"}=$fmime;              $active_chk = 'active';
     } else {              if ($userinfo{$srchstr} =~ m/^($role)_(\d+)/) {
  $value=~s/\s+$//s;                  $role_end = $2;
     }                  if ($userinfo{$srchstr} =~ m/^($role)_($role_end)_(\d+)$/) {
     &add_to_env("form.$name",$value);                      $role_start = $3;
  }                  }
  if ($i<$#lines) {              }
     $i++;              if ($role_start > 0) {
     $lines[$i]=~                  if (time < $role_start) {
  /Content\-Disposition\:\s*form\-data\;\s*name\=\"([^\"]+)\"/i;                      $active_chk = 'future';
     $name=$1;                  }
     $value='';              }
     if ($lines[$i]=~/filename\=\"([^\"]+)\"/i) {              if ($role_end > 0) {
  $fname=$1;                  if (time > $role_end) {
  if                       $active_chk = 'previous';
                             ($lines[$i+1]=~/Content\-Type\:\s*([\w\-\/]+)/i) {                  }
  $fmime=$1;              }
  $i++;          }
     } else {      }
  $fmime='';      return $active_chk;
     }  }
     } else {  
  $fname='';  ###############################################
  $fmime='';  
     }  =pod
     $i++;  
  }  =item get_sections
     } else {  
  $value.=$lines[$i]."\n";  Determines all the sections for a course including
   sections with students and sections containing other roles.
   Incoming parameters: domain, course number, reference to 
   section hash (keys to be section/group IDs), reference to 
   array containing roles for which sections should be gathered
   (optional). If the fourth argument is undefined, sections
   are gathered for any role.
    
   Returns number of sections.
   
   =cut
   
   ###############################################
   sub get_sections {
       my ($cdom,$cnum,$sectioncount,$possible_roles) = @_;
       if (!($cdom && $cnum)) { return 0; }
       my $numsections = 0;
   
       if (!defined($possible_roles) || (grep/^st$/,@$possible_roles)) {
    my ($classlist) = &Apache::loncoursedata::get_classlist($cdom,$cnum);
    my $sec_index = &Apache::loncoursedata::CL_SECTION();
    my $status_index = &Apache::loncoursedata::CL_STATUS();
    while (my ($student,$data) = each %$classlist) {
       my ($section,$status) = ($data->[$sec_index],
        $data->[$status_index]);
       unless ($section eq '-1' || $section =~ /^\s*$/) {
    if (!defined($$sectioncount{$section})) { $numsections++; }
    $$sectioncount{$section}++;
     }      }
  }   }
     }      }
     $ENV{'request.method'}=$ENV{'REQUEST_METHOD'};      my %courseroles = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum);
     $r->method_number(M_GET);      foreach my $user (sort(keys(%courseroles))) {
     $r->method('GET');   if ($user !~ /^(\w{2})/) { next; }
     $r->headers_in->unset('Content-length');   my ($role) = ($user =~ /^(\w{2})/);
    if ($possible_roles && !(grep(/^$role$/,@$possible_roles))) { next; }
    my $section;
    if ($role eq 'cr' &&
       $user =~ m-^$role/[^/]*/[^/]*/[^/]*:[^:]*:[^:]*:(\w+)-) {
       $section=$1;
    }
    if ($user =~ /^$role:[^:]*:[^:]*:(\w+)/) { $section=$1; }
    if (!defined($section) || $section eq '-1') { next; }
    if (!defined($$sectioncount{$section})) { $numsections++; } 
    $$sectioncount{$section}++;
       }
       return $numsections;
   }
   
   ###############################################
                                                                                     
   =pod
                                                                                     
   =item coursegroups
   
   Retrieve information about groups in a course,
   
   Input:
   1. Reference to hash to populate with group information. 
   2. Optional course domain
   3. Optional course number
   4. Optional group name
   
   Course domain and number will be taken from user's
   environment if not supplied. Optional group name will'
   be passed to lonnet::get_coursegroups() as a regexp to
   use in the call to the dump function.
   
   Output
   Returns number of groups in the course (subject to the
   optional group name filter).
   
   Side effects:
   Populates the referenced curr_groups hash, with key,
   value pairs. Keys are group names, corresponding values
   are scalars containing group information in XML. This
   can be sent to &get_group_settings() to be parsed.     
   
   =cut 
   
   ###############################################
   
   sub coursegroups {
       my ($curr_groups,$cdom,$cnum,$group) = @_;
       my $numgroups;
       if (!defined($cdom) || !defined($cnum)) {
           my $cid =  $env{'request.course.id'};
           $cdom = $env{'course.'.$cid.'.domain'};
           $cnum = $env{'course.'.$cid.'.num'};
       }
       %{$curr_groups} = &Apache::lonnet::get_coursegroups($cdom,$cnum,$group);
       my ($tmp) = keys(%{$curr_groups});
       if ($tmp=~/^error:/) {
           unless ($tmp eq 'error: 2 tie(GDBM) Failed while attempting dump') {
               &logthis('Error retrieving groups: '.$tmp.' in '.$cnum.':'.
                                                                      $cdom);
           }
           $numgroups = 0;
       } else {
           $numgroups = keys(%{$curr_groups});
       }
       return $numgroups;
   }
   
   ###############################################
   
   =pod
   
   =item get_group_settings
   
   Uses TokeParser to extract group information from the
   XML used to describe course groups.
   
   Input:
   Scalar containing XML  - as retrieved from &coursegroups().
   
   Output:
   Hash containing group information as key=values for (a), and
   hash of hashes for (b)
   
   Keys (in two categories):
   (a) groupname, creator, creation, modified, startdate,enddate.
   Corresponding values are name of the group, creator of the group
   (username:domain), UNIX time for date group was created, and
   settings were last modified, and default start and end access
   times for group members.
   
   (b) functions returned in hash of hashes.
   Outer hash key is functions.
   Inner hash keys are chat,discussion,email,files,homepage,roster.
   Corresponding values are either on or off, depending on
   whether this type of functionality is available for the group.
   
   =cut
                                                                                    
   ###############################################
   
   sub get_group_settings {
       my ($groupinfo)=@_;
       my $parser=HTML::TokeParser->new(\$groupinfo);
       my $token;
       my $tool = '';
       my $role = '';
       my %content=();
       while ($token=$parser->get_token) {
           if ($token->[0] eq 'S')  {
               my $entry=$token->[1];
               if ($entry eq 'functions' || $entry eq 'autosec') {
                   %{$content{$entry}} = ();
                   $tool = $entry;
               } elsif ($entry eq 'role') {
                   if ($tool eq 'autosec') {
                       $role = $token->[2]{id};
                   }
               } else {
                   my $value=$parser->get_text('/'.$entry);
                   if ($entry eq 'name') {
                       if ($tool eq 'functions') {
                           my $function = $token->[2]{id};
                           $content{$tool}{$function} = $value;
                       }
                   } elsif ($entry eq 'groupname') {
                       $content{$entry}=&Apache::lonnet::unescape($value);
                   } elsif (($entry eq 'roles') || ($entry eq 'types') ||
                            ($entry eq 'sectionpick') || ($entry eq 'defpriv')) {
                       push(@{$content{$entry}},$value);
                   } elsif ($entry eq 'section') {
                       if ($tool eq 'autosec'  && $role ne '') {
                           push(@{$content{$tool}{$role}},$value);
                       }
                   } else {
                       $content{$entry}=$value;
                   }
               }
           } elsif ($token->[0] eq 'E') {
               if ($token->[1] eq 'functions' || $token->[1] eq 'autosec') {
                   $tool = '';
               } elsif ($token->[1] eq 'role') {
                   $role = '';
               }
   
           }
       }
       return %content;
   }
   
   sub check_group_access {
       my ($group) = @_;
       my $access = 1;
       my $now = time;
       my ($start,$end) = split(/\./,$env{'user.role.gr/'.$env{'request.course,id'}.'/'.$group});
       if (($end!=0) && ($end<$now)) { $access = 0; }
       if (($start!=0) && ($start>$now)) { $access=0; }
       return $access;
   }
   
   ###############################################
   
   =pod
                                                                                   
   =item get_course_users
                                                                                   
   Retrieves usernames:domains for users in the specified course
   with specific role(s), and access status. 
   
   Incoming parameters:
   1. course domain
   2. course number
   3. access status: users must have - either active, 
   previous, future, or all.
   4. reference to array of permissible roles
   5. reference to array of section restrictions (optional)
   6. reference to results object (hash of hashes).
   7. reference to optional userdata hash
   Keys of top level hash are roles.
   Keys of inner hashes are username:domain, with 
   values set to access type.
   Optional userdata hash returns an array with arguments in the 
   same order as loncoursedata::get_classlist() for student data.
   
   Entries for end, start, section and status are blank because
   of the possibility of multiple values for non-student roles.
   
   =cut
                                                                                   
   ###############################################
                                                                                   
   sub get_course_users {
       my ($cdom,$cnum,$types,$roles,$sections,$users,$userdata) = @_;
       my %idx = ();
   
       $idx{udom} = &Apache::loncoursedata::CL_SDOM();
       $idx{uname} =  &Apache::loncoursedata::CL_SNAME();
       $idx{end} = &Apache::loncoursedata::CL_END();
       $idx{start} = &Apache::loncoursedata::CL_START();
       $idx{id} = &Apache::loncoursedata::CL_ID();
       $idx{section} = &Apache::loncoursedata::CL_SECTION();
       $idx{fullname} = &Apache::loncoursedata::CL_FULLNAME();
       $idx{status} = &Apache::loncoursedata::CL_STATUS();
   
       if (grep(/^st$/,@{$roles})) {
           my ($classlist,$keylist)=&Apache::loncoursedata::get_classlist($cdom,$cnum);
           my $now = time;
           foreach my $student (keys(%{$classlist})) {
               my $match = 0;
               if ((ref($sections) eq 'ARRAY') && (@{$sections} > 0)) {
    unless(grep(/^\Q$$classlist{$student}[$idx{section}]\E$/,
       @{$sections})) {
       next;
    }
               } 
               if (defined($$types{'active'})) {
                   if ($$classlist{$student}[$idx{status}] eq 'Active') {
                       push(@{$$users{st}{$student}},'active');
                       $match = 1;
                   }
               }
               if (defined($$types{'previous'})) {
                   if ($$classlist{$student}[$idx{end}] <= $now) {
                       push(@{$$users{st}{$student}},'previous');
                       $match = 1;
                   }
               }
               if (defined($$types{'future'})) {
                   if (($$classlist{$student}[$idx{start}] > $now) && ($$classlist{$student}[$idx{end}] > $now) || ($$classlist{$student}[$idx{end}] == 0) || ($$classlist{$student}[$idx{end}] eq '')) {
                       push(@{$$users{st}{$student}},'future');
                       $match = 1;
                   }
               }
               if ($match && defined($userdata)) {
                   $$userdata{$student} = $$classlist{$student};
               }
           }
       }
       if ((@{$roles} > 0) && (@{$roles} ne "st")) {
           my @coursepersonnel = &Apache::lonnet::getkeys('nohist_userroles',$cdom,$cnum);
           foreach my $person (@coursepersonnel) {
               my $match = 0;
               my ($role,$user) = ($person =~ /^([^:]*):([^:]+:[^:]+)/);
               $user =~ s/:$//;
               if (($role) && (grep(/^\Q$role\E$/,@{$roles}))) {
                   my ($uname,$udom,$usec) = split(/:/,$user);
                   if ($usec ne '' && (ref($sections) eq 'ARRAY') && 
       @{$sections} > 0) {
       unless(grep(/^\Q$usec\E$/,@{$sections})) {
    next;
       }
                   }
                   if ($uname ne '' && $udom ne '') {
                       my $status = &check_user_status($udom,$uname,$cdom,$cnum,$role);
                       foreach my $type (keys(%{$types})) { 
                           if ($status eq $type) {
                               @{$$users{$role}{$user}} = $type;
                               $match = 1;
                           }
                       }
                       if ($match && defined($userdata) &&
                           !exists($$userdata{$uname.':'.$udom})) {
    &get_user_info($udom,$uname,\%idx,$userdata);
                       }
                   }
               }
           }
           if (grep(/^ow$/,@{$roles})) {
               if ((defined($cdom)) && (defined($cnum))) {
                   my %csettings = &Apache::lonnet::get('environment',['internal.courseowner'],$cdom,$cnum);
                   if ( defined($csettings{'internal.courseowner'}) ) {
                       my $owner = $csettings{'internal.courseowner'};
                       @{$$users{'ow'}{$owner.':'.$cdom}} = 'any';
                       if (defined($userdata) && 
    !exists($$userdata{$owner.':'.$cdom})) {
    &get_user_info($cdom,$owner,\%idx,$userdata);
       }
                   }
               }
           }
       }
       return;
   }
   
   sub get_user_info {
       my ($udom,$uname,$idx,$userdata) = @_;
       $$userdata{$uname.':'.$udom}[$$idx{fullname}] = 
    &plainname($uname,$udom,'lastname');
       $$userdata{$uname.':'.$udom}[$$idx{uname}] = $uname;
       $$userdata{$uname.':'.$udom}[$$idx{udom}] = $udom;
       return;
 }  }
   
 =pod  =pod
   
 =item * get_unprocessed_cgi($query,$possible_names)  =item * get_unprocessed_cgi($query,$possible_names)
   
 Modify the %ENV hash to contain unprocessed CGI form parameters held in  Modify the %env hash to contain unprocessed CGI form parameters held in
 $query.  The parameters listed in $possible_names (an array reference),  $query.  The parameters listed in $possible_names (an array reference),
 will be set in $ENV{'form.name'} if they do not already exist.  will be set in $env{'form.name'} if they do not already exist.
   
 Typically called with $ENV{'QUERY_STRING'} as the first parameter.    Typically called with $ENV{'QUERY_STRING'} as the first parameter.  
 $possible_names is an ref to an array of form element names.  As an example:  $possible_names is an ref to an array of form element names.  As an example:
 get_unprocessed_cgi($ENV{'QUERY_STRING'},['uname','udom']);  get_unprocessed_cgi($ENV{'QUERY_STRING'},['uname','udom']);
 will result in $ENV{'form.uname'} and $ENV{'form.udom'} being set.  will result in $env{'form.uname'} and $env{'form.udom'} being set.
   
 =cut  =cut
   
 sub get_unprocessed_cgi {  sub get_unprocessed_cgi {
   my ($query,$possible_names)= @_;    my ($query,$possible_names)= @_;
   # $Apache::lonxml::debug=1;    # $Apache::lonxml::debug=1;
   foreach (split(/&/,$query)) {    foreach my $pair (split(/&/,$query)) {
     my ($name, $value) = split(/=/,$_);      my ($name, $value) = split(/=/,$pair);
     $name = &Apache::lonnet::unescape($name);      $name = &Apache::lonnet::unescape($name);
     if (!defined($possible_names) || (grep {$_ eq $name} @$possible_names)) {      if (!defined($possible_names) || (grep {$_ eq $name} @$possible_names)) {
       $value =~ tr/+/ /;        $value =~ tr/+/ /;
       $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;        $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
       &Apache::lonxml::debug("Seting :$name: to :$value:");        unless (defined($env{'form.'.$name})) { &add_to_env('form.'.$name,$value) };
       unless (defined($ENV{'form.'.$name})) { &add_to_env('form.'.$name,$value) };  
     }      }
   }    }
 }  }
Line 2680  returns cache-controlling header code Line 4070  returns cache-controlling header code
 =cut  =cut
   
 sub cacheheader {  sub cacheheader {
   unless ($ENV{'request.method'} eq 'GET') { return ''; }      unless ($env{'request.method'} eq 'GET') { return ''; }
   my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);      my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
   my $output .='<meta HTTP-EQUIV="Expires" CONTENT="'.$date.'" />      my $output .='<meta HTTP-EQUIV="Expires" CONTENT="'.$date.'" />
                 <meta HTTP-EQUIV="Cache-control" CONTENT="no-cache" />                  <meta HTTP-EQUIV="Cache-control" CONTENT="no-cache" />
                 <meta HTTP-EQUIV="Pragma" CONTENT="no-cache" />';                  <meta HTTP-EQUIV="Pragma" CONTENT="no-cache" />';
   return $output;      return $output;
 }  }
   
 =pod  =pod
Line 2697  specifies header code to not have cache Line 4087  specifies header code to not have cache
 =cut  =cut
   
 sub no_cache {  sub no_cache {
   my ($r) = @_;      my ($r) = @_;
   unless ($ENV{'request.method'} eq 'GET') { return ''; }      if ($ENV{'REQUEST_METHOD'} ne 'GET' &&
   #my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);   $env{'request.method'} ne 'GET') { return ''; }
   $r->no_cache(1);      my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime(time));
   $r->header_out("Pragma" => "no-cache");      $r->no_cache(1);
   #$r->header_out("Expires" => $date);      $r->header_out("Expires" => $date);
       $r->header_out("Pragma" => "no-cache");
 }  }
   
 sub content_type {  sub content_type {
     my ($r,$type,$charset) = @_;      my ($r,$type,$charset) = @_;
       if ($r) {
    #  Note that printout.pl calls this with undef for $r.
    &no_cache($r);
       }
       if ($env{'browser.mathml'} && $type eq 'text/html') { $type='text/xml'; }
     unless ($charset) {      unless ($charset) {
  $charset=&Apache::lonlocal::current_encoding;   $charset=&Apache::lonlocal::current_encoding;
     }      }
Line 2722  sub content_type { Line 4118  sub content_type {
   
 =item * add_to_env($name,$value)   =item * add_to_env($name,$value) 
   
 adds $name to the %ENV hash with value  adds $name to the %env hash with value
 $value, if $name already exists, the entry is converted to an array  $value, if $name already exists, the entry is converted to an array
 reference and $value is added to the array.  reference and $value is added to the array.
   
Line 2730  reference and $value is added to the arr Line 4126  reference and $value is added to the arr
   
 sub add_to_env {  sub add_to_env {
   my ($name,$value)=@_;    my ($name,$value)=@_;
   if (defined($ENV{$name})) {    if (defined($env{$name})) {
     if (ref($ENV{$name})) {      if (ref($env{$name})) {
       #already have multiple values        #already have multiple values
       push(@{ $ENV{$name} },$value);        push(@{ $env{$name} },$value);
     } else {      } else {
       #first time seeing multiple values, convert hash entry to an arrayref        #first time seeing multiple values, convert hash entry to an arrayref
       my $first=$ENV{$name};        my $first=$env{$name};
       undef($ENV{$name});        undef($env{$name});
       push(@{ $ENV{$name} },$first,$value);        push(@{ $env{$name} },$first,$value);
     }      }
   } else {    } else {
     $ENV{$name}=$value;      $env{$name}=$value;
   }    }
 }  }
   
Line 2749  sub add_to_env { Line 4145  sub add_to_env {
   
 =item * get_env_multiple($name)   =item * get_env_multiple($name) 
   
 gets $name from the %ENV hash, it seemlessly handles the cases where multiple  gets $name from the %env hash, it seemlessly handles the cases where multiple
 values may be defined and end up as an array ref.  values may be defined and end up as an array ref.
   
 returns an array of values  returns an array of values
Line 2759  returns an array of values Line 4155  returns an array of values
 sub get_env_multiple {  sub get_env_multiple {
     my ($name) = @_;      my ($name) = @_;
     my @values;      my @values;
     if (defined($ENV{$name})) {      if (defined($env{$name})) {
         # exists is it an array          # exists is it an array
         if (ref($ENV{$name})) {          if (ref($env{$name})) {
             @values=@{ $ENV{$name} };              @values=@{ $env{$name} };
         } else {          } else {
             $values[0]=$ENV{$name};              $values[0]=$env{$name};
         }          }
     }      }
     return(@values);      return(@values);
Line 2782  sub get_env_multiple { Line 4178  sub get_env_multiple {
 =item * upfile_store($r)  =item * upfile_store($r)
   
 Store uploaded file, $r should be the HTTP Request object,  Store uploaded file, $r should be the HTTP Request object,
 needs $ENV{'form.upfile'}  needs $env{'form.upfile'}
 returns $datatoken to be put into hidden field  returns $datatoken to be put into hidden field
   
 =cut  =cut
   
 sub upfile_store {  sub upfile_store {
     my $r=shift;      my $r=shift;
     $ENV{'form.upfile'}=~s/\r/\n/gs;      $env{'form.upfile'}=~s/\r/\n/gs;
     $ENV{'form.upfile'}=~s/\f/\n/gs;      $env{'form.upfile'}=~s/\f/\n/gs;
     $ENV{'form.upfile'}=~s/\n+/\n/gs;      $env{'form.upfile'}=~s/\n+/\n/gs;
     $ENV{'form.upfile'}=~s/\n+$//gs;      $env{'form.upfile'}=~s/\n+$//gs;
   
     my $datatoken=$ENV{'user.name'}.'_'.$ENV{'user.domain'}.      my $datatoken=$env{'user.name'}.'_'.$env{'user.domain'}.
  '_enroll_'.$ENV{'request.course.id'}.'_'.time.'_'.$$;   '_enroll_'.$env{'request.course.id'}.'_'.time.'_'.$$;
     {      {
         my $datafile = $r->dir_config('lonDaemons').          my $datafile = $r->dir_config('lonDaemons').
                            '/tmp/'.$datatoken.'.tmp';                             '/tmp/'.$datatoken.'.tmp';
         if ( open(my $fh,">$datafile") ) {          if ( open(my $fh,">$datafile") ) {
             print $fh $ENV{'form.upfile'};              print $fh $env{'form.upfile'};
             close($fh);              close($fh);
         }          }
     }      }
Line 2812  sub upfile_store { Line 4208  sub upfile_store {
 =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,
 needs $ENV{'form.datatoken'},  needs $env{'form.datatoken'},
 sets $ENV{'form.upfile'} to the contents of the file  sets $env{'form.upfile'} to the contents of the file
   
 =cut  =cut
   
Line 2822  sub load_tmp_file { Line 4218  sub load_tmp_file {
     my @studentdata=();      my @studentdata=();
     {      {
         my $studentfile = $r->dir_config('lonDaemons').          my $studentfile = $r->dir_config('lonDaemons').
                               '/tmp/'.$ENV{'form.datatoken'}.'.tmp';                                '/tmp/'.$env{'form.datatoken'}.'.tmp';
         if ( open(my $fh,"<$studentfile") ) {          if ( open(my $fh,"<$studentfile") ) {
             @studentdata=<$fh>;              @studentdata=<$fh>;
             close($fh);              close($fh);
         }          }
     }      }
     $ENV{'form.upfile'}=join('',@studentdata);      $env{'form.upfile'}=join('',@studentdata);
 }  }
   
 =pod  =pod
Line 2837  sub load_tmp_file { Line 4233  sub load_tmp_file {
   
 Separate uploaded file into records  Separate uploaded file into records
 returns array of records,  returns array of records,
 needs $ENV{'form.upfile'} and $ENV{'form.upfiletype'}  needs $env{'form.upfile'} and $env{'form.upfiletype'}
   
 =cut  =cut
   
 sub upfile_record_sep {  sub upfile_record_sep {
     if ($ENV{'form.upfiletype'} eq 'xml') {      if ($env{'form.upfiletype'} eq 'xml') {
     } else {      } else {
  return split(/\n/,$ENV{'form.upfile'});   my @records;
    foreach my $line (split(/\n/,$env{'form.upfile'})) {
       if ($line=~/^\s*$/) { next; }
       push(@records,$line);
    }
    return @records;
     }      }
 }  }
   
Line 2852  sub upfile_record_sep { Line 4253  sub upfile_record_sep {
   
 =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'}
   
 =cut  =cut
   
   sub takeleft {
       my $index=shift;
       return substr('0000'.$index,-4,4);
   }
   
 sub record_sep {  sub record_sep {
     my $record=shift;      my $record=shift;
     my %components=();      my %components=();
     if ($ENV{'form.upfiletype'} eq 'xml') {      if ($env{'form.upfiletype'} eq 'xml') {
     } elsif ($ENV{'form.upfiletype'} eq 'space') {      } elsif ($env{'form.upfiletype'} eq 'space') {
         my $i=0;          my $i=0;
         foreach (split(/\s+/,$record)) {          foreach my $field (split(/\s+/,$record)) {
             my $field=$_;  
             $field=~s/^(\"|\')//;              $field=~s/^(\"|\')//;
             $field=~s/(\"|\')$//;              $field=~s/(\"|\')$//;
             $components{$i}=$field;              $components{&takeleft($i)}=$field;
             $i++;              $i++;
         }          }
     } elsif ($ENV{'form.upfiletype'} eq 'tab') {      } elsif ($env{'form.upfiletype'} eq 'tab') {
         my $i=0;          my $i=0;
         foreach (split(/\t/,$record)) {          foreach my $field (split(/\t/,$record)) {
             my $field=$_;  
             $field=~s/^(\"|\')//;              $field=~s/^(\"|\')//;
             $field=~s/(\"|\')$//;              $field=~s/(\"|\')$//;
             $components{$i}=$field;              $components{&takeleft($i)}=$field;
             $i++;              $i++;
         }          }
     } else {      } else {
Line 2893  sub record_sep { Line 4297  sub record_sep {
                 $field=~s/^\s*$delimiter//;                  $field=~s/^\s*$delimiter//;
                 $field=~s/$delimiter\s*$//;                  $field=~s/$delimiter\s*$//;
             }              }
             $components{$i}=$field;              $components{&takeleft($i)}=$field;
     $i++;      $i++;
         }          }
     }      }
Line 2930  sub upfile_select_html { Line 4334  sub upfile_select_html {
     return $Str;      return $Str;
 }  }
   
   sub get_samples {
       my ($records,$toget) = @_;
       my @samples=({});
       my $got=0;
       foreach my $rec (@$records) {
    my %temp = &record_sep($rec);
    if (! grep(/\S/, values(%temp))) { next; }
    if (%temp) {
       $samples[$got]=\%temp;
       $got++;
       if ($got == $toget) { last; }
    }
       }
       return \@samples;
   }
   
 ######################################################  ######################################################
 ######################################################  ######################################################
   
Line 2947  Apache Request ref, $records is an array Line 4367  Apache Request ref, $records is an array
 ######################################################  ######################################################
 sub csv_print_samples {  sub csv_print_samples {
     my ($r,$records) = @_;      my ($r,$records) = @_;
     my (%sone,%stwo,%sthree);      my $samples = &get_samples($records,3);
     %sone=&record_sep($$records[0]);  
     if (defined($$records[1])) {%stwo=&record_sep($$records[1]);}  
     if (defined($$records[2])) {%sthree=&record_sep($$records[2]);}  
     #  
     $r->print(&mt('Samples').'<br /><table border="2"><tr>');      $r->print(&mt('Samples').'<br /><table border="2"><tr>');
     foreach (sort({$a <=> $b} keys(%sone))) {       foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) { 
         $r->print('<th>'.&mt('Column&nbsp;[_1]',($_+1)).'</th>'); }          $r->print('<th>'.&mt('Column&nbsp;[_1]',($sample+1)).'</th>'); }
     $r->print('</tr>');      $r->print('</tr>');
     foreach my $hash (\%sone,\%stwo,\%sthree) {      foreach my $hash (@$samples) {
  $r->print('<tr>');   $r->print('<tr>');
  foreach (sort({$a <=> $b} keys(%sone))) {   foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
     $r->print('<td>');      $r->print('<td>');
     if (defined($$hash{$_})) { $r->print($$hash{$_}); }      if (defined($$hash{$sample})) { $r->print($$hash{$sample}); }
     $r->print('</td>');      $r->print('</td>');
  }   }
  $r->print('</tr>');   $r->print('</tr>');
Line 2987  $d is an array of 2 element arrays (inte Line 4404  $d is an array of 2 element arrays (inte
 ######################################################  ######################################################
 sub csv_print_select_table {  sub csv_print_select_table {
     my ($r,$records,$d) = @_;      my ($r,$records,$d) = @_;
     my $i=0;my %sone;      my $i=0;
     %sone=&record_sep($$records[0]);      my $samples = &get_samples($records,1);
     $r->print(&mt('Associate columns with student attributes.')."\n".      $r->print(&mt('Associate columns with student attributes.')."\n".
      '<table border="2"><tr>'.       '<table border="2"><tr>'.
               '<th>'.&mt('Attribute').'</th>'.                '<th>'.&mt('Attribute').'</th>'.
               '<th>'.&mt('Column').'</th></tr>'."\n");                '<th>'.&mt('Column').'</th></tr>'."\n");
     foreach (@$d) {      foreach my $array_ref (@$d) {
  my ($value,$display,$defaultcol)=@{ $_ };   my ($value,$display,$defaultcol)=@{ $array_ref };
  $r->print('<tr><td>'.$display.'</td>');   $r->print('<tr><td>'.$display.'</td>');
   
  $r->print('<td><select name=f'.$i.   $r->print('<td><select name=f'.$i.
   ' onchange="javascript:flip(this.form,'.$i.');">');    ' onchange="javascript:flip(this.form,'.$i.');">');
  $r->print('<option value="none"></option>');   $r->print('<option value="none"></option>');
  foreach (sort({$a <=> $b} keys(%sone))) {   foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
     $r->print('<option value="'.$_.'"'.      $r->print('<option value="'.$sample.'"'.
                       ($_ eq $defaultcol ? ' selected ' : '').                        ($sample eq $defaultcol ? ' selected="selected" ' : '').
                       '>Column '.($_+1).'</option>');                        '>Column '.($sample+1).'</option>');
  }   }
  $r->print('</select></td></tr>'."\n");   $r->print('</select></td></tr>'."\n");
  $i++;   $i++;
Line 3031  $d is an array of 2 element arrays (inte Line 4448  $d is an array of 2 element arrays (inte
 ######################################################  ######################################################
 sub csv_samples_select_table {  sub csv_samples_select_table {
     my ($r,$records,$d) = @_;      my ($r,$records,$d) = @_;
     my %sone; my %stwo; my %sthree;  
     my $i=0;      my $i=0;
     #      #
       my $samples = &get_samples($records,3);
     $r->print('<table border=2><tr><th>'.      $r->print('<table border=2><tr><th>'.
               &mt('Field').'</th><th>'.&mt('Samples').'</th></tr>');                &mt('Field').'</th><th>'.&mt('Samples').'</th></tr>');
     %sone=&record_sep($$records[0]);  
     if (defined($$records[1])) {%stwo=&record_sep($$records[1]);}      foreach my $key (sort(keys(%{ $samples->[0] }))) {
     if (defined($$records[2])) {%sthree=&record_sep($$records[2]);}  
     #  
     foreach (sort keys %sone) {  
  $r->print('<tr><td><select name="f'.$i.'"'.   $r->print('<tr><td><select name="f'.$i.'"'.
   ' onchange="javascript:flip(this.form,'.$i.');">');    ' onchange="javascript:flip(this.form,'.$i.');">');
  foreach (@$d) {   foreach my $option (@$d) {
     my ($value,$display,$defaultcol)=@{ $_ };      my ($value,$display,$defaultcol)=@{ $option };
     $r->print('<option value="'.$value.'"'.      $r->print('<option value="'.$value.'"'.
                       ($i eq $defaultcol ? ' selected ':'').'>'.                        ($i eq $defaultcol ? ' selected="selected" ':'').'>'.
                       $display.'</option>');                        $display.'</option>');
  }   }
  $r->print('</select></td><td>');   $r->print('</select></td><td>');
  if (defined($sone{$_})) { $r->print($sone{$_}."</br>\n"); }   foreach my $line (0..2) {
  if (defined($stwo{$_})) { $r->print($stwo{$_}."</br>\n"); }      if (defined($samples->[$line]{$key})) { 
  if (defined($sthree{$_})) { $r->print($sthree{$_}."</br>\n"); }   $r->print($samples->[$line]{$key}."<br />\n"); 
       }
    }
  $r->print('</td></tr>');   $r->print('</td></tr>');
  $i++;   $i++;
     }      }
Line 3141  the routine &Apache::lonnet::transfer_pr Line 4557  the routine &Apache::lonnet::transfer_pr
 my $uniq=0;  my $uniq=0;
 sub get_cgi_id {  sub get_cgi_id {
     $uniq=($uniq+1)%100000;      $uniq=($uniq+1)%100000;
     return (time.'_'.$uniq);      return (time.'_'.$$.'_'.$uniq);
 }  }
   
 ############################################################  ############################################################
Line 3177  they are plotted.  If undefined, default Line 4593  they are plotted.  If undefined, default
 =item @Values: An array of array references.  Each array reference holds data  =item @Values: An array of array references.  Each array reference holds data
 to be plotted in a stacked bar chart.  to be plotted in a stacked bar chart.
   
   =item If the final element of @Values is a hash reference the key/value
   pairs will be added to the graph definition.
   
 =back  =back
   
 Returns:  Returns:
Line 3197  sub DrawBarGraph { Line 4616  sub DrawBarGraph {
                   '#66ccff', '#ff9999', '#cccc33', '#660000', '#33cc66',                    '#66ccff', '#ff9999', '#cccc33', '#660000', '#33cc66',
                   ];                     ]; 
     }      }
       my $extra_settings = {};
       if (ref($Values[-1]) eq 'HASH') {
           $extra_settings = pop(@Values);
       }
     #      #
     my $identifier = &get_cgi_id();      my $identifier = &get_cgi_id();
     my $id = 'cgi.'.$identifier;              my $id = 'cgi.'.$identifier;        
     if (! @Values || ref($Values[0]) ne 'ARRAY') {      if (! @Values || ref($Values[0]) ne 'ARRAY') {
         return '';          return '';
     }      }
       #
       my @Labels;
       if (defined($labels)) {
           @Labels = @$labels;
       } else {
           for (my $i=0;$i<@{$Values[0]};$i++) {
               push (@Labels,$i+1);
           }
       }
       #
     my $NumBars = scalar(@{$Values[0]});      my $NumBars = scalar(@{$Values[0]});
       if ($NumBars < scalar(@Labels)) { $NumBars = scalar(@Labels); }
     my %ValuesHash;      my %ValuesHash;
     my $NumSets=1;      my $NumSets=1;
     foreach my $array (@Values) {      foreach my $array (@Values) {
Line 3213  sub DrawBarGraph { Line 4647  sub DrawBarGraph {
     }      }
     #      #
     my ($height,$width,$xskip,$bar_width) = (200,120,1,15);      my ($height,$width,$xskip,$bar_width) = (200,120,1,15);
     if ($NumBars < 10) {      if ($NumBars < 3) {
           $width = 120+$NumBars*32;
           $xskip = 1;
           $bar_width = 30;
       } elsif ($NumBars < 5) {
           $width = 120+$NumBars*20;
           $xskip = 1;
           $bar_width = 20;
       } elsif ($NumBars < 10) {
         $width = 120+$NumBars*15;          $width = 120+$NumBars*15;
         $xskip = 1;          $xskip = 1;
         $bar_width = 15;          $bar_width = 15;
Line 3231  sub DrawBarGraph { Line 4673  sub DrawBarGraph {
         $bar_width = 4;          $bar_width = 4;
     }      }
     #      #
     my @Labels;  
     if (defined($labels)) {  
         @Labels = @$labels;  
     } else {  
         for (my $i=0;$i<@{$Values[0]};$i++) {  
             push (@Labels,$i+1);  
         }  
     }  
     #  
     $Max = 1 if ($Max < 1);      $Max = 1 if ($Max < 1);
     if ( int($Max) < $Max ) {      if ( int($Max) < $Max ) {
         $Max++;          $Max++;
Line 3262  sub DrawBarGraph { Line 4695  sub DrawBarGraph {
     $ValuesHash{$id.'.bar_width'} = $bar_width;      $ValuesHash{$id.'.bar_width'} = $bar_width;
     $ValuesHash{$id.'.labels'} = join(',',@Labels);      $ValuesHash{$id.'.labels'} = join(',',@Labels);
     #      #
       # Deal with other parameters
       while (my ($key,$value) = each(%$extra_settings)) {
           $ValuesHash{$id.'.'.$key} = $value;
       }
       #
     &Apache::lonnet::appenv(%ValuesHash);      &Apache::lonnet::appenv(%ValuesHash);
     return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';      return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';
 }  }
Line 3496  Inputs: Line 4934  Inputs:
 sub chartlink {  sub chartlink {
     my ($linktext, $sname, $sdomain) = @_;      my ($linktext, $sname, $sdomain) = @_;
     my $link = '<a href="/adm/statistics?reportSelected=student_assessment'.      my $link = '<a href="/adm/statistics?reportSelected=student_assessment'.
         '&SelectedStudent='.&Apache::lonnet::escape($sname.':'.$sdomain).          '&amp;SelectedStudent='.&Apache::lonnet::escape($sname.':'.$sdomain).
         '&chartoutputmode='.HTML::Entities::encode('html, with all links').          '&amp;chartoutputmode='.HTML::Entities::encode('html, with all links').
        '">'.$linktext.'</a>';         '">'.$linktext.'</a>';
 }  }
   
Line 3538  Returns: both routines return nothing Line 4976  Returns: both routines return nothing
 sub store_course_settings {  sub store_course_settings {
     # save to the environment      # save to the environment
     # appenv the same items, just to be safe      # appenv the same items, just to be safe
     my $courseid = $ENV{'request.course.id'};      my $courseid = $env{'request.course.id'};
     my $coursedom = $ENV{'course.'.$courseid.'.domain'};      my $udom  = $env{'user.domain'};
       my $uname = $env{'user.name'};
     my ($prefix,$Settings) = @_;      my ($prefix,$Settings) = @_;
     my %SaveHash;      my %SaveHash;
     my %AppHash;      my %AppHash;
     while (my ($setting,$type) = each(%$Settings)) {      while (my ($setting,$type) = each(%$Settings)) {
         my $basename = 'internal.'.$prefix.'.'.$setting;          my $basename = join('.','internal',$courseid,$prefix,$setting);
         my $envname = 'course.'.$courseid.'.'.$basename;          my $envname = 'environment.'.$basename;
         if (exists($ENV{'form.'.$setting})) {          if (exists($env{'form.'.$setting})) {
             # Save this value away              # Save this value away
             if ($type eq 'scalar' &&              if ($type eq 'scalar' &&
                 (! exists($ENV{$envname}) ||                   (! exists($env{$envname}) || 
                  $ENV{$envname} ne $ENV{'form.'.$setting})) {                   $env{$envname} ne $env{'form.'.$setting})) {
                 $SaveHash{$basename} = $ENV{'form.'.$setting};                  $SaveHash{$basename} = $env{'form.'.$setting};
                 $AppHash{$envname}   = $ENV{'form.'.$setting};                  $AppHash{$envname}   = $env{'form.'.$setting};
             } elsif ($type eq 'array') {              } elsif ($type eq 'array') {
                 my $stored_form;                  my $stored_form;
                 if (ref($ENV{'form.'.$setting})) {                  if (ref($env{'form.'.$setting})) {
                     $stored_form = join(',',                      $stored_form = join(',',
                                         map {                                          map {
                                             &Apache::lonnet::escape($_);                                              &Apache::lonnet::escape($_);
                                         } sort(@{$ENV{'form.'.$setting}}));                                          } sort(@{$env{'form.'.$setting}}));
                 } else {                  } else {
                     $stored_form =                       $stored_form = 
                         &Apache::lonnet::escape($ENV{'form.'.$setting});                          &Apache::lonnet::escape($env{'form.'.$setting});
                 }                  }
                 # Determine if the array contents are the same.                  # Determine if the array contents are the same.
                 if ($stored_form ne $ENV{$envname}) {                  if ($stored_form ne $env{$envname}) {
                     $SaveHash{$basename} = $stored_form;                      $SaveHash{$basename} = $stored_form;
                     $AppHash{$envname}   = $stored_form;                      $AppHash{$envname}   = $stored_form;
                 }                  }
Line 3573  sub store_course_settings { Line 5012  sub store_course_settings {
         }          }
     }      }
     my $put_result = &Apache::lonnet::put('environment',\%SaveHash,      my $put_result = &Apache::lonnet::put('environment',\%SaveHash,
                                           $coursedom,                                            $udom,$uname);
                                           $ENV{'course.'.$courseid.'.num'});  
     if ($put_result !~ /^(ok|delayed)/) {      if ($put_result !~ /^(ok|delayed)/) {
         &Apache::lonnet::logthis('unable to save form parameters, '.          &Apache::lonnet::logthis('unable to save form parameters, '.
                                  'got error:'.$put_result);                                   'got error:'.$put_result);
Line 3585  sub store_course_settings { Line 5023  sub store_course_settings {
 }  }
   
 sub restore_course_settings {  sub restore_course_settings {
     my $courseid = $ENV{'request.course.id'};      my $courseid = $env{'request.course.id'};
     my ($prefix,$Settings) = @_;      my ($prefix,$Settings) = @_;
     while (my ($setting,$type) = each(%$Settings)) {      while (my ($setting,$type) = each(%$Settings)) {
         next if (exists($ENV{'form.'.$setting}));          next if (exists($env{'form.'.$setting}));
         my $envname = 'course.'.$courseid.'.internal.'.$prefix.          my $envname = 'environment.internal.'.$courseid.'.'.$prefix.
             '.'.$setting;              '.'.$setting;
         if (exists($ENV{$envname})) {          if (exists($env{$envname})) {
             if ($type eq 'scalar') {              if ($type eq 'scalar') {
                 $ENV{'form.'.$setting} = $ENV{$envname};                  $env{'form.'.$setting} = $env{$envname};
             } elsif ($type eq 'array') {              } elsif ($type eq 'array') {
                 $ENV{'form.'.$setting} = [                   $env{'form.'.$setting} = [ 
                                            map {                                              map { 
                                                &Apache::lonnet::unescape($_);                                                  &Apache::lonnet::unescape($_); 
                                            } split(',',$ENV{$envname})                                             } split(',',$env{$envname})
                                            ];                                             ];
             }              }
         }          }
Line 3631  sub icon { Line 5069  sub icon {
  $curfext.".gif";   $curfext.".gif";
  }   }
     }      }
     return $iconname;      return &lonhttpdurl($iconname);
 }   } 
   
   sub lonhttpdurl {
       my ($url)=@_;
       my $lonhttpd_port=$Apache::lonnet::perlvar{'lonhttpdPort'};
       if (!defined($lonhttpd_port)) { $lonhttpd_port='8080'; }
       return 'http://'.$ENV{'SERVER_NAME'}.':'.$lonhttpd_port.$url;
   }
   
   sub connection_aborted {
       my ($r)=@_;
       $r->print(" ");$r->rflush();
       my $c = $r->connection;
       return $c->aborted();
   }
   
   #    Escapes strings that may have embedded 's that will be put into
   #    strings as 'strings'.
   sub escape_single {
       my ($input) = @_;
       $input =~ s/\\/\\\\/g; # Escape the \'s..(must be first)>
       $input =~ s/\'/\\\'/g; # Esacpe the 's....
       return $input;
   }
   
   #  Same as escape_single, but escape's "'s  This 
   #  can be used for  "strings"
   sub escape_double {
       my ($input) = @_;
       $input =~ s/\\/\\\\/g; # Escape the /'s..(must be first)>
       $input =~ s/\"/\\\"/g; # Esacpe the "s....
       return $input;
   }
    
   #   Escapes the last element of a full URL.
   sub escape_url {
       my ($url)   = @_;
       my @urlslices = split(/\//, $url,-1);
       my $lastitem = &Apache::lonnet::escape(pop(@urlslices));
       return join('/',@urlslices).'/'.$lastitem;
   }
 =pod  =pod
   
 =back  =back
Removed from v.1.198  
changed lines
  Added in v.1.358

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