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

Diff for /loncom/interface/loncommon.pm between versions 1.211 and 1.382

version 1.211, 2004/09/10 08:42:21 version 1.382, 2006/06/12 22:30:04
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();
   use LONCAPA;
   
 my $readit;  my $readit;
   
Line 75  my %language; Line 77  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 108  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 125  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 155  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 179  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 194  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 254  sub browser_and_searcher_javascript { Line 258  sub browser_and_searcher_javascript {
     if (!defined($mode)) { $mode='edit'; }      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 265  sub browser_and_searcher_javascript { Line 270  sub browser_and_searcher_javascript {
         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 290  sub browser_and_searcher_javascript { Line 301  sub browser_and_searcher_javascript {
         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 298  sub browser_and_searcher_javascript { Line 311  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 320  sub storeresurl { Line 334  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 351  ENDSTDBRW Line 368  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 367  sub selectstudent_link { Line 386  sub selectstudent_link {
   
 sub coursebrowser_javascript {  sub coursebrowser_javascript {
     my ($domainfilter)=@_;      my ($domainfilter)=@_;
       my $crs_or_grp_alert = &mt('Please select the type of LON-CAPA entity - Course or Group - for which you wish to add/modify a user role');
    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,crstype) {
         var url = '/adm/pickcourse?';          var url = '/adm/pickcourse?';
         var filter;          var filter;
         if (filter != null) {          if (filter != null) {
Line 387  sub coursebrowser_javascript { Line 407  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;
           }
           if (crstype == 'Course/Group') {
               if (formname == 'cu') {
                   crstype = document.cu.crstype.options[document.cu.crstype.selectedIndex].value; 
                   if (crstype == "") {
                       alert("$crs_or_grp_alert");
                       return;
                   }
               }
           }
           if (crstype !=null && crstype != '') {
               url += '&type='+crstype;
           }
         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 398  ENDSTDBRW Line 439  ENDSTDBRW
 }  }
   
 sub selectcourse_link {  sub selectcourse_link {
    my ($form,$unameele,$udomele,$desc)=@_;     my ($form,$unameele,$udomele,$desc,$extra_element,$multflag,$selecttype)=@_;
     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.'","'.$selecttype.'");'."'>".&mt('Select [_1]',$selecttype)."</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
   
Line 483  sub linked_select_forms { Line 549  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 532  END Line 598  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 542  END Line 608  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 578  sub help_open_topic { Line 644  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 611  sub help_open_topic { Line 677  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 643  sub help_open_menu { Line 710  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);
Line 652  sub help_open_menu { Line 719  sub help_open_menu {
     my $link='';      my $link='';
     my $title = &mt('Get 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 = &escape($$datum);
     }      }
   
     if (!$stayOnPage) {      if (!$stayOnPage) {
          $link = "javascript:helpMenu('open')";           $link = "javascript:helpMenu('open')";
     } else {      } else {
         $link = "javascript:helpMenu('display')";          $link = "javascript:helpMenu('display')";
     }      }
     my $banner_link = "/adm/helpmenu?page=banner&color=$color&function=$function&topic=$topic&component_help=$component_help&faq=$faq&bug=$bug&origurl=$origurl&stamp=$timestamp&stayonpage=$stayOnPage";      my $banner_link = "/adm/helpmenu?page=banner&amp;color=$color&amp;function=$function&amp;topic=$topic&amp;component_help=$component_help&amp;faq=$faq&amp;bug=$bug&amp;origurl=$origurl&amp;stamp=$timestamp&amp;stayonpage=$stayOnPage";
     my $details_link = "/adm/helpmenu?page=body&color=$color&function=$function&topic=$topic&component_help=$component_help&faq=$faq&bug=$bug&origurl=$origurl&stamp=$timestamp";      my $details_link = "/adm/helpmenu?page=body&amp;color=$color&amp;function=$function&amp;topic=$topic&amp;component_help=$component_help&amp;faq=$faq&amp;bug=$bug&amp;origurl=$origurl&amp;stamp=$timestamp";
     my $template;      my $template;
     if ($text ne "") {      if ($text ne "") {
  $template .=    $template .= 
   "<table bgcolor='#773311' cellspacing='1' cellpadding='1' border='0'><tr>".    "<table bgcolor='#CC3300' cellspacing='1' cellpadding='1' border='0'><tr>".
   "<td bgcolor='#886622'><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/lonIcons/helpgateway.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 ($component_help) {
  if (!$text) {   if (!$text) {
Line 696  ENDTEMPLATE Line 789  ENDTEMPLATE
        $width,$height).' '.$template;         $width,$height).' '.$template;
  } else {   } else {
     my $help_text;      my $help_text;
     $help_text=&Apache::lonnet::unescape($topic);      $help_text=&unescape($topic);
     $template='<table><tr><td>'.      $template='<table><tr><td>'.
  &help_open_topic($component_help,$help_text,$stayOnPage,   &help_open_topic($component_help,$help_text,$stayOnPage,
  $width,$height).'</td><td>'.$template.   $width,$height).'</td><td>'.$template.
Line 709  ENDTEMPLATE Line 802  ENDTEMPLATE
   
 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 723  sub help_open_bug { Line 816  sub help_open_bug {
     $topic=~s/\W+/\+/g;      $topic=~s/\W+/\+/g;
     my $link='';      my $link='';
     my $template='';      my $template='';
     my $url=$Apache::lonnet::perlvar{'BugzillaHost'}.'enter_bug.cgi?product=LON-CAPA&bug_file_loc='.      my $url=$Apache::lonnet::perlvar{'BugzillaHost'}.'enter_bug.cgi?product=LON-CAPA&amp;bug_file_loc='.
  &Apache::lonnet::escape($ENV{'REQUEST_URI'}).'&component='.$topic;   &escape($ENV{'REQUEST_URI'}).'&amp;component='.$topic;
     if (!$stayOnPage)      if (!$stayOnPage)
     {      {
  $link = "javascript:void(open('$url', 'Bugzilla', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))";   $link = "javascript:void(open('$url', 'Bugzilla', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))";
Line 743  sub help_open_bug { Line 836  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 753  ENDTEMPLATE Line 847  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 787  sub help_open_faq { Line 881  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 800  ENDTEMPLATE Line 895  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 816  sub csv_translate { Line 1003  sub csv_translate {
     return $text;      return $text;
 }  }
   
   
 ###############################################################  ###############################################################
 ###############################################################  ###############################################################
   
Line 840  Currently supported formats: Line 1026  Currently supported formats:
   
 =item h3  =item h3
   
   =item h4
   
   =item i
   
 =item date  =item date
   
 =back  =back
Line 862  sub define_excel_formats { Line 1052  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=>
                                             'mm/dd/yyyy hh:mm:ss');                                              'mm/dd/yyyy hh:mm:ss');
     return $format;      return $format;
Line 872  sub define_excel_formats { Line 1064  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  
 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)  Create an Excel worksheet.  If it fails, output message on the
 must be written to the HTML page once. It will prove the Javascript  request object and return undefs.
 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 977  sub get_domains { Line 1168  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 992  sub domain_select { Line 1183  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 1040  sub select_form { Line 1253  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 1079  sub select_level_form { Line 1293  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 1107  sub select_dom_form { Line 1321  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 1132  given $domain. Line 1346  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 1156  sub home_server_option_list { Line 1370  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 1208  Outputs: Line 1423  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 1406  sub authform_nochange{ Line 1623  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 1441  sub authform_kerberos{ Line 1659  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 1473  sub authform_internal{ Line 1692  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 1500  sub authform_local{ Line 1719  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 1516  sub authform_filesystem{ Line 1735  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 1644  sub initialize_keywords { Line 1863  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 1701  sub get_related_words { Line 1920  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 1725  sub get_related_words { Line 1944  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 1765  if the user does not Line 1988  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 1779  sub nickname { Line 2001  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 1792  Gets a users screenname and returns it a Line 2028  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,$username,$domain)=@_;      my ($link,$username,$domain,$subject,$text)=@_;
     return       return 
         '<a href="/adm/email?compose=individual&'.          '<a href="/adm/email?compose=individual&'.
         'recname='.$username.'&recdom='.$domain.'" '.          'recname='.$username.'&recdom='.$domain.
    '&subject='.&escape($subject).'&text='.&escape($text).'" '.
         'title="'.&mt('Send message').'">'.$link.'</a>';          'title="'.&mt('Send message').'">'.$link.'</a>';
 }  }
 # --------------------------------------------------------------- Notes Wrapper  # --------------------------------------------------------------- Notes Wrapper
Line 1833  sub syllabuswrapper { Line 2072  sub syllabuswrapper {
 }  }
   
 sub track_student_link {  sub track_student_link {
     my ($linktext,$sname,$sdom,$target) = @_;      my ($linktext,$sname,$sdom,$target,$start) = @_;
     my $link ="/adm/trackstudent";      my $link ="/adm/trackstudent?";
     my $title = 'View recent activity';      my $title = 'View recent activity';
     if (defined($sname) && $sname !~ /^\s*$/ &&      if (defined($sname) && $sname !~ /^\s*$/ &&
         defined($sdom)  && $sdom  !~ /^\s*$/) {          defined($sdom)  && $sdom  !~ /^\s*$/) {
         $link .= "?selected_student=$sname:$sdom";          $link .= "selected_student=$sname:$sdom";
         $title .= ' of this student';          $title .= ' of this student';
     }      } 
     if (defined($target) && $target !~ /^\s*$/) {      if (defined($target) && $target !~ /^\s*$/) {
         $target = qq{target="$target"};          $target = qq{target="$target"};
     } else {      } else {
         $target = '';          $target = '';
     }      }
       if ($start) { $link.='&amp;start='.$start; }
     return qq{<a href="$link" title="$title" $target>$linktext</a>};      return qq{<a href="$link" title="$title" $target>$linktext</a>};
 }  }
   
   
   
 =pod  =pod
   
 =back  =back
Line 1964  category Line 2202  category
 =cut  =cut
   
 sub filecategorytypes {  sub filecategorytypes {
     return @{$category_extensions{lc($_[0])}};      my ($cat) = @_;
       return @{$category_extensions{lc($cat)}};
 }  }
   
 =pod  =pod
Line 1979  sub fileembstyle { Line 2218  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 2035  sub fileextensions { Line 2278  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 2049  sub display_languages { Line 2292  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 2076  sub preferred_languages { Line 2319  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 2136  sub get_previous_attempt { Line 2379  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 2159  sub get_previous_attempt { Line 2402  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>'.&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=&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 2211  sub relative_to_absolute { Line 2454  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 2245  sub get_student_view { Line 2488  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 2285  sub get_student_answers { Line 2528  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 2293  Returns: A link to grades.pm such as to Line 2536  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)) {      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=&escape($symb);
  '&userdom='.$udom.'&command=submission">'.$text.'</a>';      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)) {
    (my $cursymb, my $courseid,$udom,$uname)=
       &Apache::lonxml::whichuser($symb);
    if (!$symb) { $symb=$cursymb; }
       }
       if (!$symb) { $symb=&Apache::lonnet::symbread(); }
       $symb=&escape($symb);
       if ($target) { $target="target=\"$target\""; }
       return '<a href="/adm/parmset?&command=set&'.
    'symb='.$symb.'&uname='.$uname.
    '&udom='.$udom.'" '.$target.'>'.$text.'</a>';
 }  }
 ##############################################  ##############################################
   
Line 2327  sub timehash { Line 2619  sub timehash {
              'dlsav'   => $ltime[8] );               'dlsav'   => $ltime[8] );
 }  }
   
   sub utc_string {
       my ($date)=@_;
       return strftime("%Y%m%dT%H%M%SZ",gmtime($date));
   }
   
 sub maketime {  sub maketime {
     my %th=@_;      my %th=@_;
     return POSIX::mktime(      return POSIX::mktime(
Line 2337  sub maketime { Line 2634  sub maketime {
 #########################################  #########################################
   
 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 2349  sub findallcourses { Line 2652  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 2378  sub determinedomain { Line 2681  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 2402  sub domainlogo { Line 2705  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 2427  Returns: value of designparamter $which Line 2728  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 2438  sub designparm { Line 2739  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 2481  Inputs: Line 2782  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
   
   =item * $no_inline_link, if true and in remote mode, don't show the 
            'Switch To Inline Menu' link
   
   
 =back  =back
   
 Returns: A uniform header for LON-CAPA web pages.    Returns: A uniform header for LON-CAPA web pages.  
Line 2491  other decorations will be returned. Line 2807  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,$no_inline_link)=@_;
   
     $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 $font =   &designparm($function.'.font',$domain);
     my $tabbg=&designparm($function.'.tabbg',$domain);      my $pgbg   = $bgcolor || &designparm($function.'.pgbg',$domain);
     my $font=&designparm($function.'.font',$domain);  
     my $link=&designparm($function.'.link',$domain);      my %design = ( 'style'   => 'margin-top: 0px',
     my $alink=&designparm($function.'.alink',$domain);     'bgcolor' => $pgbg,
     my $vlink=&designparm($function.'.vlink',$domain);     'text'    => $font,
     my $sidebg=&designparm($function.'.sidebg',$domain);                     'alink'   => &designparm($function.'.alink',$domain),
 # Accessibility font enhance     'vlink'   => &designparm($function.'.vlink',$domain),
     unless ($addentries) { $addentries=''; }     'link'    => &designparm($function.'.link',$domain),);
     my $addstyle='';      @$addentries{keys(%design)} = @design{keys(%design)};
     if ($ENV{'browser.fontenhance'} eq 'on') {  
  $addstyle=' font-size: x-large;';  
     }  
  # role and realm   # role and realm
     my ($role,$realm)      my ($role,$realm) = split(/\./,$env{'request.role'},2);
        =&Apache::lonnet::plaintext((split(/\./,$ENV{'request.role'}))[0]);      if ($role  eq 'ca') {
           my ($rdom,$rname) = ($realm =~ m-^/(\w+)/(\w+)$-);
           $realm = &plainname($rname,$rdom).':'.$rdom;
       } 
 # realm  # realm
     if ($ENV{'request.course.id'}) {      if ($env{'request.course.id'}) {
  $realm=          if ($env{'request.role'} !~ /^cr/) {
          $ENV{'course.'.$ENV{'request.course.id'}.'.description'};              $role = &Apache::lonnet::plaintext($role,&course_type());
           }
    $realm = $env{'course.'.$env{'request.course.id'}.'.description'};
       } else {
           $role = &Apache::lonnet::plaintext($role);
     }      }
     unless ($realm) { $realm='&nbsp;'; }      if (!$realm) { $realm='&nbsp;'; }
 # Set messages  # Set messages
     my $messages=&domainlogo($domain);      my $messages=&domainlogo($domain);
 # 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 = "<body $extra_body_attr>".
 <style>   &Apache::lontexconvert::init_math_support();
 h1, h2, h3, th { font-family: Arial, Helvetica, sans-serif }  
 a:focus { color: red; background: yellow }       if ($bodyonly 
 </style>   || ($env{'request.state'} eq 'construct' 
 <body bgcolor="$pgbg" text="$font" alink="$alink" vlink="$vlink" link="$link"      && $env{'environment.remote'} ne 'off' )) {
 style="margin-top: 0px;$addstyle" $addentries>  
 END  
     my $upperleft='<img src="http://'.$ENV{'HTTP_HOST'}.':'.  
                    $lonhttpdPort.$img.'" alt="'.$function.'" />';  
     if ($bodyonly) {  
         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>';
 # No Remote   }
  my $roleinfo=(<<ENDROLE);   return $bodytag;
 <td bgcolor="$tabbg" align="right">      }
 <p>  
 <font size="2" face="Arial, Helvetica, sans-serif">  
     $ENV{'environment.firstname'}      
     $ENV{'environment.middlename'}      my $roleinfo=(<<ENDROLE);
     $ENV{'environment.lastname'}  <td class="LC_title_bar_who">
     $ENV{'environment.generation'}  <div class="LC_title_bar_name">
     </font>&nbsp;      $env{'environment.firstname'}
 <br />      $env{'environment.middlename'}
 <font size="2" face="Arial, Helvetica, sans-serif">$role</font>&nbsp;      $env{'environment.lastname'}
 <br />      $env{'environment.generation'}
 <font size="2" face="Arial, Helvetica, sans-serif">$realm</font>&nbsp;      &nbsp;
 </p>  </div>
   <div class="LC_title_bar_role">
   $role&nbsp;
   </div>
   <div class="LC_title_bar_realm">
   $realm&nbsp;
   </div>
 </td>  </td>
 ENDROLE  ENDROLE
         return $bodytag.&Apache::lonmenu::menubuttons($forcereg,'web',  
                                                       $forcereg).      my $titleinfo = '<span class="LC_title_bar_title">'.$title.'</span>';
       '<table bgcolor="'.$pgbg.'" width="100%" border="0" cellspacing="3" cellpadding="3"><tr><td rowspan="3" bgcolor="'.$tabbg.'"><font face="Arial, Helvetica, sans-serif" size="+3" color="'.$font.'"><b>'.$title.      if ($customtitle) {
 '</b></font></td>'.$roleinfo.'</tr></table>';          $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 =~ s/\s+$//;
           $dc_info = '('.$dc_info.')';
       }
   
       if ($env{'environment.remote'} eq 'off') {
           # No Remote
    if ($env{'request.state'} eq 'construct') {
       $forcereg=1;
    }
   
    if (!$customtitle && $env{'request.state'} eq 'construct') {
       # this is for resources; directories have customtitle, and crumbs
               # and select recent are created in lonpubdir.pm  
       my ($uname,$thisdisfn)=
    ($env{'request.filename'} =~ m|^/home/([^/]+)/public_html/(.*)|);
       my $formaction='/priv/'.$uname.'/'.$thisdisfn;
       $formaction=~s/\/+/\//g;
   
       my $parentpath = '';
       my $lastitem = '';
       if ($thisdisfn =~ m-(.+/)([^/]*)$-) {
    $parentpath = $1;
    $lastitem = $2;
       } else {
    $lastitem = $thisdisfn;
       }
       $titleinfo = 
    &Apache::loncommon::help_open_menu('','','','',3,'Authoring').
    '<b>Construction Space</b>:&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();
           }
   
           my $titletable;
    if (!$notitle) {
       $titletable =
    '<table id="LC_title_bar">'.
                            "<tr><td> $titleinfo $dc_info</td>".$roleinfo.
    '</tr></table>';
    }
    if ($notopbar) {
       $bodytag .= $titletable;
    } else {
       if ($env{'request.state'} eq 'construct') {
                   $bodytag .= &Apache::lonmenu::menubuttons($forcereg,$forcereg,
     $titletable);
               } else {
                   $bodytag .= &Apache::lonmenu::menubuttons($forcereg,$forcereg).
       $titletable;
               }
           }
           return $bodytag;
     }      }
   
 #  #
 # Top frame rendering, Remote is up  # Top frame rendering, Remote is up
 #  #
   
       my $upperleft='<img src="http://'.$ENV{'HTTP_HOST'}.':'.
           $lonhttpdPort.$img.'" alt="'.$function.'" />';
   
       # Explicit link to get inline menu
       my $menu= ($no_inline_link?''
          :'<br /><a href="/adm/remote?action=collapse">'.&mt('Switch to Inline Menu Mode').'</a>');
       #
       if ($notitle) {
    return $bodytag;
       }
     return(<<ENDBODY);      return(<<ENDBODY);
 $bodytag  $bodytag
 <table width="100%" cellspacing="0" border="0" cellpadding="0">  <table id="LC_title_bar" class="LC_with_remote">
 <tr><td bgcolor="$sidebg">  <tr><td class="LC_title_bar_role_logo">$upperleft</td>
 $upperleft</td>      <td class="LC_title_bar_domain_logo">$messages&nbsp;</td>
 <td bgcolor="$sidebg" align="right">$messages&nbsp;</td>  
 </tr>  </tr>
 <tr>  <tr><td>$titleinfo $dc_info $menu</td>
 <td rowspan="3" bgcolor="$tabbg">  $roleinfo
 &nbsp;<font size="5" face="Arial, Helvetica, sans-serif"><b>$title</b></font>  
 <td bgcolor="$tabbg" align="right">  
 <font size="2" face="Arial, Helvetica, sans-serif">  
     $ENV{'environment.firstname'}  
     $ENV{'environment.middlename'}  
     $ENV{'environment.lastname'}  
     $ENV{'environment.generation'}  
     </font>&nbsp;  
 </td>  
 </tr>  </tr>
 <tr><td bgcolor="$tabbg" align="right">  </table>
 <font size="2" face="Arial, Helvetica, sans-serif">$role</font>&nbsp;  
 </td></tr>  
 <tr>  
 <td bgcolor="$tabbg" align="right"><font size="2" face="Arial, Helvetica, sans-serif">$realm</font>&nbsp;</td></tr>  
 </table><br />  
 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_or_bgcolor =
            $bgcolor ||
            &designparm($function.'.pgbg',  $domain);
       my $pgbg   = &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;
   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; }
   .LC_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 {
     width: 100%;
     background: $pgbg;
     border: 0px;
     border-spacing: 2px 2px;
     padding: 0px;
     margin: 0px;
     border-collapse: separate;
   }
   table#LC_title_bar {
     width: 100%;
     border: 0;
     border-spacing: 0px 0px;
     padding: 0px 2px 0px 2px;
     background: $pgbg;
     font-family: $sans;
     border-collapse: separate;
   }
   table#LC_breadcrumbs {
     width: 100%;
     border: 0;
     border-spacing: 0px;
     padding: 0px 2px 0px 2px;
     background: $pgbg;
     font-family: $sans;
     border-collapse: separate;
   }
   table#LC_title_bar.LC_with_remote {
     width: 100%;
     border: 0;
     border-spacing: 0;
     background: $pgbg;
     font-family: $sans;
     border-collapse: collapse;
   }
   table#LC_title_bar td {
     padding: 3px;
     background: $tabbg;
   }
   table#LC_title_bar td.LC_title_bar_who {
     background: $tabbg;
     color: $font;
     font: medium $sans;
     text-align: right;
   }
   span.LC_title_bar_title {
     font: bold xx-large $sans;
   }
   table#LC_title_bar td.LC_title_bar_domain_logo {
     background: $sidebg;
     text-align: right;
     padding: 0px;
   }
   table#LC_title_bar td.LC_title_bar_role_logo {
     background: $sidebg;
     padding: 0px;
   }
   
   table#LC_menubuttons_mainmenu {
     background: $pgbg;
     border: 0px;
     border-spacing: 1px;
     padding: 0px 1px;
     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_top_nav td.LC_top_nav_logo {
     background: $tabbg;
     text-align: right;
   }
   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;
   }
   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 $function = $args->{'function'} || &get_users_function();
       my $domain   = $args->{'domain'}   || &determinedomain();
       my $bgcolor  = $args->{'bgcolor'}  || &designparm($function.'.pgbg',$domain);
       my $url = join(':',$env{'user.name'},$env{'user.domain'},
      $env{'environment.color.timestamp'},
      $function,$domain,$bgcolor);
   
       $url = '/adm/css/'.&escape($url).'.css';
   
       my $result =
    '<head>'.
    '<link rel="stylesheet" type="text/css" href="'.$url.'" />'.
    &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
   
                     no_inline_link -> if true and in remote mode, don't show the 
                                       'Switch To Inline Menu' link
   
   =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'},       $args->{'no_inline_link'});
    }
       }
   
       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) = @_;
       $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{</}{<\\/}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>';
       }
   
       sub start_data_table_header_row {
    return  '<tr class="LC_header_row">';
       }
   
       sub end_data_table_header_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 2609  Returns either 'student','coordinator',' Line 3718  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 2624  sub get_users_function { Line 3733  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 ID.
     $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 array containing roles for which sections should 
   be gathered (optional). If the third argument is undefined,
   sections are gathered for any role.
    
   Returns section hash (keys are section IDs, values are
   number of users in each section), subject to the
   optional roles filter.
   
   =cut
   
   ###############################################
   sub get_sections {
       my ($cdom,$cnum,$possible_roles) = @_;
       if (!defined($cdom) || !defined($cnum)) {
           my $cid =  $env{'request.course.id'};
   
    return if (!defined($cid));
   
           $cdom = $env{'course.'.$cid.'.domain'};
           $cnum = $env{'course.'.$cid.'.num'};
       }
   
       my %sectioncount;
   
       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*$/) {
    $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; }
    $sectioncount{$section}++;
       }
       return %sectioncount;
   }
   
   ###############################################
   
   =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 = &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 2732  returns cache-controlling header code Line 4018  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 2749  specifies header code to not have cache Line 4035  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 2774  sub content_type { Line 4066  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 2782  reference and $value is added to the arr Line 4074  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 2801  sub add_to_env { Line 4093  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 2811  returns an array of values Line 4103  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 2834  sub get_env_multiple { Line 4126  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 2864  sub upfile_store { Line 4156  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 2874  sub load_tmp_file { Line 4166  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 2889  sub load_tmp_file { Line 4181  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 2904  sub upfile_record_sep { Line 4201  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 2945  sub record_sep { Line 4245  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 2982  sub upfile_select_html { Line 4282  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 2999  Apache Request ref, $records is an array Line 4315  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 3039  $d is an array of 2 element arrays (inte Line 4352  $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 3083  $d is an array of 2 element arrays (inte Line 4396  $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 3193  the routine &Apache::lonnet::transfer_pr Line 4505  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 3229  they are plotted.  If undefined, default Line 4541  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 3249  sub DrawBarGraph { Line 4564  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 3265  sub DrawBarGraph { Line 4595  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 3283  sub DrawBarGraph { Line 4621  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 3300  sub DrawBarGraph { Line 4629  sub DrawBarGraph {
     $Title  = '' if (! defined($Title));      $Title  = '' if (! defined($Title));
     $xlabel = '' if (! defined($xlabel));      $xlabel = '' if (! defined($xlabel));
     $ylabel = '' if (! defined($ylabel));      $ylabel = '' if (! defined($ylabel));
     $ValuesHash{$id.'.title'}    = &Apache::lonnet::escape($Title);      $ValuesHash{$id.'.title'}    = &escape($Title);
     $ValuesHash{$id.'.xlabel'}   = &Apache::lonnet::escape($xlabel);      $ValuesHash{$id.'.xlabel'}   = &escape($xlabel);
     $ValuesHash{$id.'.ylabel'}   = &Apache::lonnet::escape($ylabel);      $ValuesHash{$id.'.ylabel'}   = &escape($ylabel);
     $ValuesHash{$id.'.y_max_value'} = $Max;      $ValuesHash{$id.'.y_max_value'} = $Max;
     $ValuesHash{$id.'.NumBars'}  = $NumBars;      $ValuesHash{$id.'.NumBars'}  = $NumBars;
     $ValuesHash{$id.'.NumSets'}  = $NumSets;      $ValuesHash{$id.'.NumSets'}  = $NumSets;
Line 3314  sub DrawBarGraph { Line 4643  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 3377  sub DrawXYGraph { Line 4711  sub DrawXYGraph {
     $ylabel = '' if (! defined($ylabel));      $ylabel = '' if (! defined($ylabel));
     my %ValuesHash =       my %ValuesHash = 
         (          (
          $id.'.title'  => &Apache::lonnet::escape($Title),           $id.'.title'  => &escape($Title),
          $id.'.xlabel' => &Apache::lonnet::escape($xlabel),           $id.'.xlabel' => &escape($xlabel),
          $id.'.ylabel' => &Apache::lonnet::escape($ylabel),           $id.'.ylabel' => &escape($ylabel),
          $id.'.y_max_value'=> $Max,           $id.'.y_max_value'=> $Max,
          $id.'.labels'     => join(',',@$Xlabels),           $id.'.labels'     => join(',',@$Xlabels),
          $id.'.PlotType'   => 'XY',           $id.'.PlotType'   => 'XY',
Line 3474  sub DrawXYYGraph { Line 4808  sub DrawXYYGraph {
     $ylabel = '' if (! defined($ylabel));      $ylabel = '' if (! defined($ylabel));
     my %ValuesHash =       my %ValuesHash = 
         (          (
          $id.'.title'  => &Apache::lonnet::escape($Title),           $id.'.title'  => &escape($Title),
          $id.'.xlabel' => &Apache::lonnet::escape($xlabel),           $id.'.xlabel' => &escape($xlabel),
          $id.'.ylabel' => &Apache::lonnet::escape($ylabel),           $id.'.ylabel' => &escape($ylabel),
          $id.'.labels' => join(',',@$Xlabels),           $id.'.labels' => join(',',@$Xlabels),
          $id.'.PlotType' => 'XY',           $id.'.PlotType' => 'XY',
          $id.'.NumSets' => 2,           $id.'.NumSets' => 2,
Line 3548  Inputs: Line 4882  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='.&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 3578  a hash ref describing the data to be sto Line 4912  a hash ref describing the data to be sto
     'chartoutputmode' => 'scalar',      'chartoutputmode' => 'scalar',
     'chartoutputdata' => 'scalar',      'chartoutputdata' => 'scalar',
     'Section' => 'array',      'Section' => 'array',
       'Group' => 'array',
     'StudentData' => 'array',      'StudentData' => 'array',
     'Maps' => 'array');      'Maps' => 'array');
   
Line 3590  Returns: both routines return nothing Line 4925  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($_);                                              &escape($_);
                                         } sort(@{$ENV{'form.'.$setting}}));                                          } sort(@{$env{'form.'.$setting}}));
                 } else {                  } else {
                     $stored_form =                       $stored_form = 
                         &Apache::lonnet::escape($ENV{'form.'.$setting});                          &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 3625  sub store_course_settings { Line 4961  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 3637  sub store_course_settings { Line 4972  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($_);                                                  &unescape($_); 
                                            } split(',',$ENV{$envname})                                             } split(',',$env{$envname})
                                            ];                                             ];
             }              }
         }          }
Line 3660  sub restore_course_settings { Line 4995  sub restore_course_settings {
 ############################################################  ############################################################
 ############################################################  ############################################################
   
 sub propath {  sub course_type {
     my ($udom,$uname)=@_;      my ($cid) = @_;
     $udom=~s/\W//g;      if (!defined($cid)) {
     $uname=~s/\W//g;          $cid = $env{'request.course.id'};
     my $subdir=$uname.'__';      }
     $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;      if (defined($env{'course.'.$cid.'type'})) {
     my $proname="$Apache::lonnet::perlvar{'lonUsersDir'}/$udom/$subdir/$uname";          return $env{'course.'.$cid.'type'};
     return $proname;      } else {
 }           return 'Course';
       }
   }
   
 sub icon {  sub icon {
     my ($file)=@_;      my ($file)=@_;
Line 3683  sub icon { Line 5020  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 = &escape(pop(@urlslices));
       return join('/',@urlslices).'/'.$lastitem;
   }
 =pod  =pod
   
 =back  =back
Removed from v.1.211  
changed lines
  Added in v.1.382

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