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

Diff for /loncom/interface/loncommon.pm between versions 1.134 and 1.385

version 1.134, 2003/10/24 13:35:37 version 1.385, 2006/06/22 17:34:40
Line 25 Line 25
 #  #
 # http://www.lon-capa.org/  # http://www.lon-capa.org/
 #  #
 # YEAR=2001  
 # 2/13-12/7 Guy Albertelli  
 # 12/21 Gerd Kortemeyer  
 # 12/25,12/28 Gerd Kortemeyer  
 # YEAR=2002  
 # 1/4 Gerd Kortemeyer  
 # 6/24,7/2 H. K. Ng  
   
 # Makes a table out of the previous attempts  # Makes a table out of the previous attempts
 # Inputs result_from_symbread, user, domain, course_id  # Inputs result_from_symbread, user, domain, course_id
Line 62  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 Apache::lonhtmlcommon();
   use Apache::loncoursedata();
   use Apache::lontexconvert();
   use LONCAPA;
   
 my $readit;  my $readit;
   
 =pod   ##
   ## Global Variables
 =head1 Global Variables  ##
   
 =cut  
   
 # ----------------------------------------------- Filetypes/Languages/Copyright  # ----------------------------------------------- Filetypes/Languages/Copyright
 my %language;  my %language;
 my %supported_language;  my %supported_language;
 my %cprtag;  my %cprtag;
 my %fe; my %fd;  my %scprtag;
   my %fe; my %fd; my %fm;
 my %category_extensions;  my %category_extensions;
   
 # ---------------------------------------------- Designs  # ---------------------------------------------- Designs
Line 90  my %category_extensions; Line 85  my %category_extensions;
 my %designhash;  my %designhash;
   
 # ---------------------------------------------- Thesaurus variables  # ---------------------------------------------- Thesaurus variables
   #
 # FIXME: I don't think it's necessary to document these things;  # %Keywords:
 # they're privately used - Jeremy  #      A hash used by &keyword to determine if a word is considered a keyword.
   # $thesaurus_db_file 
 =pod  #      Scalar containing the full path to the thesaurus database.
   
 =over 4  
   
 =item * %Keywords    
   
 A hash used by &keyword to determine if a word is considered a keyword.  
   
 =item * $thesaurus_db_file  
   
 Scalar containing the full path to the thesaurus database.                   
   
 =back  
   
 =cut  
   
 my %Keywords;  my %Keywords;
 my $thesaurus_db_file;  my $thesaurus_db_file;
   
 # ----------------------------------------------------------------------- BEGIN  #
   # Initialize values from language.tab, copyright.tab, filetypes.tab,
 # FIXME: I don't think this needs to be documented, it prepares  # thesaurus.tab, and filecategories.tab.
 # private data structures - Jeremy  #
 =pod  
   
 =head1 General Subroutines  
   
 =over 4  
   
 =item * BEGIN()   
   
 Initialize values from language.tab, copyright.tab, filetypes.tab,  
 thesaurus.tab, and filecategories.tab.  
   
 =back  
   
 =cut  
   
 # ----------------------------------------------------------------------- BEGIN  
   
 BEGIN {  BEGIN {
     # Variable initialization      # Variable initialization
     $thesaurus_db_file = $Apache::lonnet::perlvar{'lonTabDir'}."/thesaurus.db";      $thesaurus_db_file = $Apache::lonnet::perlvar{'lonTabDir'}."/thesaurus.db";
Line 141  BEGIN { Line 105  BEGIN {
     unless ($readit) {      unless ($readit) {
 # ------------------------------------------------------------------- languages  # ------------------------------------------------------------------- languages
     {      {
  my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.          my $langtabfile = $Apache::lonnet::perlvar{'lonTabDir'}.
  '/language.tab');                                     '/language.tab';
  if ($fh) {          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;
  }                  }
     }              }
  }              close($fh);
           }
     }      }
 # ------------------------------------------------------------------ copyrights  # ------------------------------------------------------------------ copyrights
     {      {
  my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonIncludes'}.          my $copyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.
   '/copyright.tab');                                    '/copyright.tab';
  if ($fh) {          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);
           }
       }
   # ----------------------------------------------------------- source copyrights
       {
           my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.
                                     '/source_copyright.tab';
           if ( open (my $fh,"<$sourcecopyrightfile") ) {
               while (my $line = <$fh>) {
                   next if ($line =~ /^\#/);
                   chomp($line);
                   my ($key,$val)=(split(/\s+/,$line,2));
                   $scprtag{$key}=$val;
               }
               close($fh);
           }
     }      }
   
 # -------------------------------------------------------------- domain designs  # -------------------------------------------------------------- domain designs
Line 175  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 $fh=Apache::File->new($designdir.'/'.$filename);      my $designfile = $designdir.'/'.$filename;
  if ($fh) {      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);
     }      }
  }   }
     }  
   
     }      }
     closedir(DIR);      closedir(DIR);
Line 194  BEGIN { Line 176  BEGIN {
   
 # ------------------------------------------------------------- file categories  # ------------------------------------------------------------- file categories
     {      {
  my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.          my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}.
   '/filecategories.tab');                                    '/filecategories.tab';
  if ($fh) {          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);
           }
   
     }      }
 # ------------------------------------------------------------------ file types  # ------------------------------------------------------------------ file types
     {      {
  my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.          my $typesfile = $Apache::lonnet::perlvar{'lonTabDir'}.
        '/filetypes.tab');                 '/filetypes.tab';
  if ($fh) {          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);
           }
     }      }
     &Apache::lonnet::logthis(      &Apache::lonnet::logthis(
               "<font color=yellow>INFO: Read file types</font>");                "<font color=yellow>INFO: Read file types</font>");
Line 245  containing javascript with two functions Line 231  containing javascript with two functions
 C<opensearcher>. Returned string does not contain E<lt>scriptE<gt>  C<opensearcher>. Returned string does not contain E<lt>scriptE<gt>
 tags.  tags.
   
 =over 4  
   
 =item * openbrowser(formname,elementname,only,omit) [javascript]  =item * openbrowser(formname,elementname,only,omit) [javascript]
   
 inputs: formname, elementname, only, omit  inputs: formname, elementname, only, omit
Line 255  formname and elementname indicate the na Line 239  formname and elementname indicate the na
 the element that the results of the browsing selection are to be placed in.   the element that the results of the browsing selection are to be placed in. 
   
 Specifying 'only' will restrict the browser to displaying only files  Specifying 'only' will restrict the browser to displaying only files
 with the given extension.  Can be a comma seperated list.  with the given extension.  Can be a comma separated list.
   
 Specifying 'omit' will restrict the browser to NOT displaying files  Specifying 'omit' will restrict the browser to NOT displaying files
 with the given extension.  Can be a comma seperated list.  with the given extension.  Can be a comma separated list.
   
 =item * opensearcher(formname, elementname) [javascript]  =item * opensearcher(formname, elementname) [javascript]
   
Line 267  Inputs: formname, elementname Line 251  Inputs: formname, elementname
 formname and elementname specify the name of the html form and the name  formname and elementname specify the name of the html form and the name
 of the element the selection from the search results will be placed in.  of the element the selection from the search results will be placed in.
   
 =back  
   
 =cut  =cut
   
 sub browser_and_searcher_javascript {  sub browser_and_searcher_javascript {
       my ($mode)=@_;
       if (!defined($mode)) { $mode='edit'; }
       my $resurl=&lastresurl();
     return <<END;      return <<END;
   // <!-- BEGIN LON-CAPA Internal
     var editbrowser = null;      var editbrowser = null;
     function openbrowser(formname,elementname,only,omit) {      function openbrowser(formname,elementname,only,omit,titleelement) {
         var url = '/res/?';          var url = '$resurl/?';
         if (editbrowser == null) {          if (editbrowser == null) {
             url += 'launch=1&';              url += 'launch=1&';
         }          }
         url += 'catalogmode=interactive&';          url += 'catalogmode=interactive&';
         url += 'mode=edit&';          url += 'mode=$mode&';
         url += 'form=' + formname + '&';          url += 'form=' + formname + '&';
         if (only != null) {          if (only != null) {
             url += 'only=' + only + '&';              url += 'only=' + only + '&';
         }           } else {
               url += 'only=&';
    }
         if (omit != null) {          if (omit != null) {
             url += 'omit=' + omit + '&';              url += 'omit=' + omit + '&';
         }          } else {
               url += 'omit=&';
    }
           if (titleelement != null) {
               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();
     }      }
     var editsearcher;      var editsearcher;
     function opensearcher(formname,elementname) {      function opensearcher(formname,elementname,titleelement) {
         var url = '/adm/searchcat?';          var url = '/adm/searchcat?';
         if (editsearcher == null) {          if (editsearcher == null) {
             url += 'launch=1&';              url += 'launch=1&';
         }          }
         url += 'catalogmode=interactive&';          url += 'catalogmode=interactive&';
         url += 'mode=edit&';          url += 'mode=$mode&';
         url += 'form=' + formname + '&';          url += 'form=' + formname + '&';
           if (titleelement != null) {
               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 311  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 {
       if ($env{'environment.lastresurl'}) {
    return $env{'environment.lastresurl'}
       } else {
    return '/res';
       }
   }
   
   sub storeresurl {
       my $resurl=&Apache::lonnet::clutter(shift);
       unless ($resurl=~/^\/res/) { return 0; }
       $resurl=~s/\/$//;
       &Apache::lonnet::put('environment',{'lastresurl' => $resurl});
       &Apache::lonnet::appenv('environment.lastresurl' => $resurl);
       return 1;
   }
   
 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 347  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 363  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) {      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 381  sub coursebrowser_javascript { Line 405  sub coursebrowser_javascript {
    }     }
         }          }
         url += 'form=' + formname + '&cnumelement='+uname+          url += 'form=' + formname + '&cnumelement='+uname+
                                     '&cdomelement='+udom;                              '&cdomelement='+udom+
                                       '&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 393  ENDSTDBRW Line 439  ENDSTDBRW
 }  }
   
 sub selectcourse_link {  sub selectcourse_link {
    my ($form,$unameele,$udomele)=@_;     my ($form,$unameele,$udomele,$desc,$extra_element,$multflag,$selecttype)=@_;
     return "<a href='".'javascript:opencrsbrowser("'.$form.'","'.$unameele.      return "<a href='".'javascript:opencrsbrowser("'.$form.'","'.$unameele.
         '","'.$udomele.'");'."'>".&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 478  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 514  function select1_changed() { Line 585  function select1_changed() {
     // in with the nuclear      // in with the nuclear
     for (i=0;i<values.length; i++) {      for (i=0;i<values.length; i++) {
         $second.options[i] = new Option(values[i]);          $second.options[i] = new Option(values[i]);
           $second.options[i].value = values[i];
         $second.options[i].text = texts[i];          $second.options[i].text = texts[i];
         if (values[i] == select2def) {          if (values[i] == select2def) {
             $second.options[i].selected = true;              $second.options[i].selected = true;
Line 526  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 536  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 572  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 584  sub help_open_topic { Line 656  sub help_open_topic {
     my $template = "";      my $template = "";
     my $link;      my $link;
   
       $topic=~s/\W/\_/g;
   
     if (!$stayOnPage)      if (!$stayOnPage)
     {      {
  $link = "javascript:void(open('/adm/help/${filename}.hlp', 'Help_for_$topic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))";   $link = "javascript:void(open('/adm/help/${filename}.hlp', 'Help_for_$topic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))";
Line 602  sub help_open_topic { Line 676  sub help_open_topic {
     }      }
   
     # Add the graphic      # Add the graphic
       my $title = &mt('Online Help');
       my $helpicon=&lonhttpdurl("/adm/help/gif/smallHelp.gif");
     $template .= <<"ENDTEMPLATE";      $template .= <<"ENDTEMPLATE";
  <a href="$link"><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 630  sub helpLatexCheatsheet { Line 706  sub helpLatexCheatsheet {
  .'</td></tr></table>';   .'</td></tr></table>';
 }  }
   
 =pod  sub help_open_menu {
       my ($color,$topic,$component_help,$function,$faq,$bug,$stayOnPage,$width,$height,$text) = @_;
       $text = "" if (not defined $text);
       $stayOnPage = 0 if (not defined $stayOnPage);
       if ($env{'browser.interface'} eq 'textual' ||
           $env{'environment.remote'} eq 'off' ) {
           $stayOnPage=1;
       }
       $width = 620 if (not defined $width);
       $height = 600 if (not defined $height);
       my $link='';
       my $title = &mt('Get help');
       my $origurl = $ENV{'REQUEST_URI'};
       $origurl=~s|^/~|/priv/|;
       my $timestamp = time;
       foreach my $datum (\$color,\$function,\$topic,\$component_help,\$faq,
          \$bug,\$origurl) {
           $$datum = &escape($$datum);
       }
       if (!$stayOnPage) {
            $link = "javascript:helpMenu('open')";
       } else {
           $link = "javascript:helpMenu('display')";
       }
       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&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;
       if ($text ne "") {
    $template .= 
     "<table bgcolor='#CC3300' cellspacing='1' cellpadding='1' border='0'><tr>".
     "<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,});
   
 =item * csv_translate($text)       $template .= <<"ENDTEMPLATE";
    <script type="text/javascript">
   // <!-- BEGIN LON-CAPA Internal
   // <![CDATA[
   function helpMenu(target) {
       var caller = this;
       if (target == 'open') {
           var newWindow = null;
           try {
               newWindow =  window.open($nothing,"helpmenu","HEIGHT=$height,WIDTH=$width,resizable=yes,scrollbars=yes" )
           }
           catch(error) {
               writeHelp(caller);
               return;
           }
           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>
    <a href="$link" title="$title"><img src="$helpicon" border="0" alt="(Help Menu)" /></a>
   ENDTEMPLATE
       if ($component_help) {
    if (!$text) {
       $template=&help_open_topic($component_help,undef,$stayOnPage,
          $width,$height).' '.$template;
    } else {
       my $help_text;
       $help_text=&unescape($topic);
       $template='<table><tr><td>'.
    &help_open_topic($component_help,$help_text,$stayOnPage,
    $width,$height).'</td><td>'.$template.
    '</td></tr></table>';
    }
       }
       if ($text ne '') { $template.='</td></tr></table>' };
       return $template;
   }
   
 Translate $text to allow it to be output as a 'comma seperated values'   sub help_open_bug {
 format.      my ($topic, $text, $stayOnPage, $width, $height) = @_;
       unless ($env{'user.adv'}) { return ''; }
       unless ($Apache::lonnet::perlvar{'BugzillaHost'}) { return ''; }
       $text = "" if (not defined $text);
       $stayOnPage = 0 if (not defined $stayOnPage);
       if ($env{'browser.interface'} eq 'textual' ||
    $env{'environment.remote'} eq 'off' ) {
    $stayOnPage=1;
       }
       $width = 600 if (not defined $width);
       $height = 600 if (not defined $height);
   
 =cut      $topic=~s/\W+/\+/g;
       my $link='';
       my $template='';
       my $url=$Apache::lonnet::perlvar{'BugzillaHost'}.'enter_bug.cgi?product=LON-CAPA&amp;bug_file_loc='.
    &escape($ENV{'REQUEST_URI'}).'&amp;component='.$topic;
       if (!$stayOnPage)
       {
    $link = "javascript:void(open('$url', 'Bugzilla', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))";
       }
       else
       {
    $link = $url;
       }
       # Add the text
       if ($text ne "")
       {
    $template .= 
     "<table bgcolor='#AA3333' cellspacing='1' cellpadding='1' border='0'><tr>".
     "<td bgcolor='#FF5555'><a href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";
       }
   
       # Add the graphic
       my $title = &mt('Report a Bug');
       my $bugicon=&lonhttpdurl("/adm/lonMisc/smallBug.gif");
       $template .= <<"ENDTEMPLATE";
    <a href="$link" title="$title"><img src="$bugicon" border="0" alt="(Bug: $topic)" /></a>
   ENDTEMPLATE
       if ($text ne '') { $template.='</td></tr></table>' };
       return $template;
   
   }
   
   sub help_open_faq {
       my ($topic, $text, $stayOnPage, $width, $height) = @_;
       unless ($env{'user.adv'}) { return ''; }
       unless ($Apache::lonnet::perlvar{'FAQHost'}) { return ''; }
       $text = "" if (not defined $text);
       $stayOnPage = 0 if (not defined $stayOnPage);
       if ($env{'browser.interface'} eq 'textual' ||
    $env{'environment.remote'} eq 'off' ) {
    $stayOnPage=1;
       }
       $width = 350 if (not defined $width);
       $height = 400 if (not defined $height);
   
       $topic=~s/\W+/\+/g;
       my $link='';
       my $template='';
       my $url=$Apache::lonnet::perlvar{'FAQHost'}.'/fom/cache/'.$topic.'.html';
       if (!$stayOnPage)
       {
    $link = "javascript:void(open('$url', 'FAQ-O-Matic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))";
       }
       else
       {
    $link = $url;
       }
   
       # Add the text
       if ($text ne "")
       {
    $template .= 
     "<table bgcolor='#337733' cellspacing='1' cellpadding='1' border='0'><tr>".
     "<td bgcolor='#448844'><a href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";
       }
   
       # Add the graphic
       my $title = &mt('View the FAQ');
       my $faqicon=&lonhttpdurl("/adm/lonMisc/smallFAQ.gif");
       $template .= <<"ENDTEMPLATE";
    <a href="$link" title="$title"><img src="$faqicon" border="0" alt="(FAQ: $topic)" /></a>
   ENDTEMPLATE
       if ($text ne '') { $template.='</td></tr></table>' };
       return $template;
   
 sub csv_translate {  
     my $text = shift;  
     $text =~ s/\"/\"\"/g;  
     $text =~ s/\n//g;  
     return $text;  
 }  }
   
   ###############################################################
   ###############################################################
   
 =pod  =pod
   
 =item * change_content_javascript():  =item * change_content_javascript():
Line 678  pretty much any HTML. Line 925  pretty much any HTML.
   
 sub change_content_javascript {  sub change_content_javascript {
     # If we're on Netscape 4, we need to use Layer-based code      # If we're on Netscape 4, we need to use Layer-based code
     if ($ENV{'browser.type'} eq 'netscape' &&      if ($env{'browser.type'} eq 'netscape' &&
  $ENV{'browser.version'} =~ /^4\./) {   $env{'browser.version'} =~ /^4\./) {
  return (<<NETSCAPE4);   return (<<NETSCAPE4);
  function change(name, content) {   function change(name, content) {
     doc = document.layers[name+"___escape"].layers[0].document;      doc = document.layers[name+"___escape"].layers[0].document;
Line 716  the area will originally contain, which Line 963  the area will originally contain, which
 sub changable_area {  sub changable_area {
     my ($name, $origContent) = @_;      my ($name, $origContent) = @_;
   
     if ($ENV{'browser.type'} eq 'netscape' &&      if ($env{'browser.type'} eq 'netscape' &&
  $ENV{'browser.version'} =~ /^4\./) {   $env{'browser.version'} =~ /^4\./) {
  # If this is netscape 4, we need to use the Layer tag   # 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>";   return "<ilayer width='100%' id='${name}___escape' overflow='none'><layer width='100%' id='$name' overflow='none'>$origContent</layer></ilayer>";
     } else {      } else {
Line 729  sub changable_area { Line 976  sub changable_area {
   
 =back  =back
   
   =head1 Excel and CSV file utility routines
   
   =over 4
   
   =cut
   
   ###############################################################
   ###############################################################
   
   =pod
   
   =item * csv_translate($text) 
   
   Translate $text to allow it to be output as a 'comma separated values' 
   format.
   
   =cut
   
   ###############################################################
   ###############################################################
   sub csv_translate {
       my $text = shift;
       $text =~ s/\"/\"\"/g;
       $text =~ s/\n/ /g;
       return $text;
   }
   
   ###############################################################
   ###############################################################
   
   =pod
   
   =item * define_excel_formats
   
   Define some commonly used Excel cell formats.
   
   Currently supported formats:
   
   =over 4
   
   =item header
   
   =item bold
   
   =item h1
   
   =item h2
   
   =item h3
   
   =item h4
   
   =item i
   
   =item date
   
   =back
   
   Inputs: $workbook
   
   Returns: $format, a hash reference.
   
   =cut
   
   ###############################################################
   ###############################################################
   sub define_excel_formats {
       my ($workbook) = @_;
       my $format;
       $format->{'header'} = $workbook->add_format(bold      => 1, 
                                                   bottom    => 1,
                                                   align     => 'center');
       $format->{'bold'} = $workbook->add_format(bold=>1);
       $format->{'h1'}   = $workbook->add_format(bold=>1, size=>18);
       $format->{'h2'}   = $workbook->add_format(bold=>1, size=>16);
       $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=>
                                               'mm/dd/yyyy hh:mm:ss');
       return $format;
   }
   
   ###############################################################
   ###############################################################
   
   =pod
   
   =item * create_workbook
   
   Create an Excel worksheet.  If it fails, output message on the
   request object and return undefs.
   
   Inputs: Apache request object
   
   Returns (undef) on failure, 
       Excel worksheet object, scalar with filename, and formats 
       from &Apache::loncommon::define_excel_formats on success
   
   =cut
   
   ###############################################################
   ###############################################################
   sub create_workbook {
       my ($r) = @_;
           #
       # Create the excel spreadsheet
       my $filename = '/prtspool/'.
           $env{'user.name'}.'_'.$env{'user.domain'}.'_'.
           time.'_'.rand(1000000000).'.xls';
       my $workbook  = Spreadsheet::WriteExcel->new('/home/httpd'.$filename);
       if (! defined($workbook)) {
           $r->log_error("Error creating excel spreadsheet $filename: $!");
           $r->print('<p>'.&mt("Unable to create new Excel file.  ".
                               "This error has been logged.  ".
                               "Please alert your LON-CAPA administrator").
                     '</p>');
           return (undef);
       }
       #
       $workbook->set_tempdir('/home/httpd/perl/tmp');
       #
       my $format = &Apache::loncommon::define_excel_formats($workbook);
       return ($workbook,$filename,$format);
   }
   
   ###############################################################
   ###############################################################
   
   =pod
   
   =item * create_text_file
   
   Create a file to write to and eventually make available to the usre.
   If file creation fails, outputs an error message on the request object and 
   return undefs.
   
   Inputs: Apache request object, and file suffix
   
   Returns (undef) on failure, 
       Filehandle and filename on success.
   
   =cut
   
   ###############################################################
   ###############################################################
   sub create_text_file {
       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 
   
   =back
   
 =cut  =cut
   
 ###############################################################  ###############################################################
Line 753  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;
 }  }
   
   # ------------------------------------------
   
   sub domain_select {
       my ($name,$value,$multiple)=@_;
       my %domains=map { 
    $_ => $_.' '.$Apache::lonnet::domaindescription{$_} 
       } &get_domains;
       if ($multiple) {
    $domains{''}=&mt('Any domain');
    return &multiple_select_form($name,$value,4,\%domains);
       } else {
    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 {
       my ($name,$value,$size,$hash,$order)=@_;
       my %selected = map { $_ => 1 } ref($value)?@{$value}:($value);
       my $output='';
       if (! defined($size)) {
           $size = 4;
           if (scalar(keys(%$hash))<4) {
               $size = scalar(keys(%$hash));
           }
       }
       $output.="\n<select name='$name' size='$size' multiple='1'>";
       my @order = ref($order) ? @$order
                               : sort(keys(%$hash));
       foreach my $key (@order) {
           $output.='<option value="'.&HTML::Entities::encode($key,'"<>&').'" ';
           $output.='selected="selected" ' if ($selected{$key});
           $output.='>'.$hash->{$key}."</option>\n";
       }
       $output.="</select>\n";
       return $output;
   }
   
 #-------------------------------------------  #-------------------------------------------
   
 =pod  =pod
Line 781  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;
 }  }
   
   sub gradeleveldescription {
       my $gradelevel=shift;
       my %gradelevels=(0 => 'Not specified',
        1 => 'Grade 1',
        2 => 'Grade 2',
        3 => 'Grade 3',
        4 => 'Grade 4',
        5 => 'Grade 5',
        6 => 'Grade 6',
        7 => 'Grade 7',
        8 => 'Grade 8',
        9 => 'Grade 9',
        10 => 'Grade 10',
        11 => 'Grade 11',
        12 => 'Grade 12',
        13 => 'Grade 13',
        14 => '100 Level',
        15 => '200 Level',
        16 => '300 Level',
        17 => '400 Level',
        18 => 'Graduate Level');
       return &mt($gradelevels{$gradelevel});
   }
   
   sub select_level_form {
       my ($deflevel,$name)=@_;
       unless ($deflevel) { $deflevel=0; }
       my $selectform = "<select name=\"$name\" size=\"1\">\n";
       for (my $i=0; $i<=18; $i++) {
           $selectform.="<option value=\"$i\" ".
               ($i==$deflevel ? 'selected="selected" ' : '').
                   ">".&gradeleveldescription($i)."</option>\n";
       }
       $selectform.="</select>";
       return $selectform;
   }
   
 #-------------------------------------------  #-------------------------------------------
   
Line 812  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 837  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 861  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 906  Outputs: Line 1416  Outputs:
   
 =back  =back
   
   =back 
   
 =cut  =cut
   
 ###############################################################  ###############################################################
 ###############################################################  ###############################################################
 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 944  sub decode_user_agent { Line 1458  sub decode_user_agent {
             $clientunicode,$clientos,);              $clientunicode,$clientos,);
 }  }
   
 =pod  
   
 =back  
   
 =cut  
   
 ###############################################################  ###############################################################
 ##    Authentication changing form generation subroutines    ##  ##    Authentication changing form generation subroutines    ##
 ###############################################################  ###############################################################
Line 990  See loncreateuser.pm for invocation and Line 1498  See loncreateuser.pm for invocation and
   
 =back  =back
   
   =back 
   
 =cut  =cut
   
 #-------------------------------------------  #-------------------------------------------
Line 1017  END Line 1527  END
         $Javascript_toUpperCase = "";          $Javascript_toUpperCase = "";
     }      }
   
       my $radioval = "'nochange'";
       if (exists($in{'curr_authtype'}) &&
           defined($in{'curr_authtype'}) &&
           $in{'curr_authtype'} ne '') {
           $radioval = "'$in{'curr_authtype'}arg'";
       }
       my $argfield = 'null';
       if ( grep/^mode$/,(keys %in) ) {
           if ($in{'mode'} eq 'modifycourse')  {
               if ( grep/^curr_authtype$/,(keys %in) ) {
                   $radioval = "'$in{'curr_authtype'}'";
               }
               if ( grep/^curr_autharg$/,(keys %in) ) {
                   unless ($in{'curr_autharg'} eq '') {
                       $argfield = "'$in{'curr_autharg'}'";
                   }
               }
           }
       }
   
     $result.=<<"END";      $result.=<<"END";
 var current = new Object();  var current = new Object();
 current.radiovalue = 'nochange';  current.radiovalue = $radioval;
 current.argfield = null;  current.argfield = $argfield;
   
 function changed_radio(choice,currentform) {  function changed_radio(choice,currentform) {
     var choicearg = choice + 'arg';      var choicearg = choice + 'arg';
Line 1080  END Line 1610  END
   
 sub authform_authorwarning{  sub authform_authorwarning{
     my $result='';      my $result='';
     $result=<<"END";      $result='<i>'.
 <i>As a general rule, only authors or co-authors should be filesystem          &mt('As a general rule, only authors or co-authors should be '.
 authenticated (which allows access to the server filesystem).</i>              'filesystem authenticated '.
 END              '(which allows access to the server filesystem).')."</i>\n";
     return $result;      return $result;
 }  }
   
Line 1093  sub authform_nochange{ Line 1623  sub authform_nochange{
               kerb_def_dom => 'MSU.EDU',                kerb_def_dom => 'MSU.EDU',
               @_,                @_,
           );            );
     my $result='';      my $result = '<label>'.&mt('[_1] Do not change login data',
     $result.=<<"END";                       '<input type="radio" name="login" value="nochange" '.
 <input type="radio" name="login" value="nochange" checked="checked"                       'checked="checked" onclick="'.
        onclick="javascript:changed_radio('nochange',$in{'formname'});" />              "javascript:changed_radio('nochange',$in{'formname'});".'" />').
 Do not change login data      '</label>';
 END  
     return $result;      return $result;
 }  }
   
Line 1109  sub authform_kerberos{ Line 1638  sub authform_kerberos{
               kerb_def_auth => 'krb4',                kerb_def_auth => 'krb4',
               @_,                @_,
               );                );
     my $result='';      my ($check4,$check5,$krbarg);
     my $check4;  
     my $check5;  
     if ($in{'kerb_def_auth'} eq 'krb5') {      if ($in{'kerb_def_auth'} eq 'krb5') {
        $check5 = " checked=\"on\"";         $check5 = " checked=\"on\"";
     } else {      } else {
        $check4 = " checked=\"on\"";         $check4 = " checked=\"on\"";
     }      }
     $result.=<<"END";      $krbarg = $in{'kerb_def_dom'};
 <input type="radio" name="login" value="krb"   
        onclick="javascript:changed_radio('krb',$in{'formname'});"      my $krbcheck = "";
        onchange="javascript:changed_radio('krb',$in{'formname'});" />      if ( grep/^curr_authtype$/,(keys %in) ) {
 Kerberos authenticated with domain          if ($in{'curr_authtype'} =~ m/^krb/) {
 <input type="text" size="10" name="krbarg" value="$in{'kerb_def_dom'}"              $krbcheck = " checked=\"on\"";
        onchange="javascript:changed_text('krb',$in{'formname'});" />              if ( grep/^curr_autharg$/,(keys %in) ) {
 <input type="radio" name="krbver" value="4" $check4 />Version 4                  $krbarg = $in{'curr_autharg'};
 <input type="radio" name="krbver" value="5" $check5 />Version 5              }
 END          }
       }
   
       my $jscall = "javascript:changed_radio('krb',$in{'formname'});";
       my $result .= &mt
           ('[_1] Kerberos authenticated with domain [_2] '.
            '[_3] Version 4 [_4] Version 5 [_5]',
            '<label><input type="radio" name="login" value="krb" '.
                'onclick="'.$jscall.'" onchange="'.$jscall.'"'.$krbcheck.' />',
            '</label><input type="text" size="10" name="krbarg" '.
                'value="'.$krbarg.'" '.
                'onchange="'.$jscall.'" />',
            '<label><input type="radio" name="krbver" value="4" '.$check4.' />',
            '</label><label><input type="radio" name="krbver" value="5" '.$check5.' />',
    '</label>');
     return $result;      return $result;
 }  }
   
Line 1136  sub authform_internal{ Line 1677  sub authform_internal{
                 kerb_def_dom => 'MSU.EDU',                  kerb_def_dom => 'MSU.EDU',
                 @_,                  @_,
                 );                  );
     my $result='';  
     $result.=<<"END";      my $intcheck = "";
 <input type="radio" name="login" value="int"      my $intarg = 'value=""';
        onchange="javascript:changed_radio('int',$args{'formname'});"      if ( grep/^curr_authtype$/,(keys %args) ) {
        onclick="javascript:changed_radio('int',$args{'formname'});" />          if ($args{'curr_authtype'} eq 'int') {
 Internally authenticated (with initial password               $intcheck = " checked=\"on\"";
 <input type="text" size="10" name="intarg" value=""              if ( grep/^curr_autharg$/,(keys %args) ) {
        onchange="javascript:changed_text('int',$args{'formname'});" />)                  $intarg = "value=\"$args{'curr_autharg'}\"";
 END              }
           }
       }
   
       my $jscall = "javascript:changed_radio('int',$args{'formname'});";
       my $result.=&mt
           ('[_1] Internally authenticated (with initial password [_2])',
            '<label><input type="radio" name="login" value="int" '.$intcheck.
                ' onchange="'.$jscall.'" onclick="'.$jscall.'" />',
            '</label><input type="text" size="10" name="intarg" '.$intarg.
                ' onchange="'.$jscall.'" />');
     return $result;      return $result;
 }  }
   
Line 1154  sub authform_local{ Line 1705  sub authform_local{
               kerb_def_dom => 'MSU.EDU',                kerb_def_dom => 'MSU.EDU',
               @_,                @_,
               );                );
     my $result='';  
     $result.=<<"END";      my $loccheck = "";
 <input type="radio" name="login" value="loc"      my $locarg = 'value=""';
        onchange="javascript:changed_radio('loc',$in{'formname'});"      if ( grep/^curr_authtype$/,(keys %in) ) {
        onclick="javascript:changed_radio('loc',$in{'formname'});" />          if ($in{'curr_authtype'} eq 'loc') {
 Local Authentication with argument              $loccheck = " checked=\"on\"";
 <input type="text" size="10" name="locarg" value=""              if ( grep/^curr_autharg$/,(keys %in) ) {
        onchange="javascript:changed_text('loc',$in{'formname'});" />                  $locarg = "value=\"$in{'curr_autharg'}\"";
 END              }
           }
       }
   
       my $jscall = "javascript:changed_radio('loc',$in{'formname'});";
       my $result.=&mt('[_1] Local Authentication with argument [_2]',
                       '<label><input type="radio" name="login" value="loc" '.$loccheck.
                           ' onchange="'.$jscall.'" onclick="'.$jscall.'" />',
                       '</label><input type="text" size="10" name="locarg" '.$locarg.
                           ' onchange="'.$jscall.'" />');
     return $result;      return $result;
 }  }
   
Line 1172  sub authform_filesystem{ Line 1732  sub authform_filesystem{
               kerb_def_dom => 'MSU.EDU',                kerb_def_dom => 'MSU.EDU',
               @_,                @_,
               );                );
     my $result='';      my $jscall = "javascript:changed_radio('fsys',$in{'formname'});";
     $result.=<<"END";      my $result.= &mt
 <input type="radio" name="login" value="fsys"           ('[_1] Filesystem Authenticated (with initial password [_2])',
        onchange="javascript:changed_radio('fsys',$in{'formname'});"           '<label><input type="radio" name="login" value="fsys" '.
        onclick="javascript:changed_radio('fsys',$in{'formname'});" />           'onchange="'.$jscall.'" onclick="'.$jscall.'" />',
 Filesystem authenticated (with initial password            '</label><input type="text" size="10" name="fsysarg" value="" '.
 <input type="text" size="10" name="fsysarg" value=""                    'onchange="'.$jscall.'" />');
        onchange="javascript:changed_text('fsys',$in{'formname'});">)  
 END  
     return $result;      return $result;
 }  }
   
 =pod  
   
 =back  
   
 =cut  
   
 ###############################################################  ###############################################################
 ##    Get Authentication Defaults for Domain                 ##  ##    Get Authentication Defaults for Domain                 ##
 ###############################################################  ###############################################################
Line 1311  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 1344  sub keyword { Line 1896  sub keyword {
   
 =item * get_related_words  =item * get_related_words
   
 Look up a word in the thesaurus.  Takes a scalar arguement and returns  Look up a word in the thesaurus.  Takes a scalar argument and returns
 an array of words.  If the keyword is not in the thesaurus, an empty array  an array of words.  If the keyword is not in the thesaurus, an empty array
 will be returned.  The order of the words returned is determined by the  will be returned.  The order of the words returned is determined by the
 database which holds them.  database which holds them.
Line 1368  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 1392  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; }
     return $name;      return $name;
 }  }
   
Line 1431  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 1445  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 1458  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,$un,$do)=@_;      my ($link,$username,$domain,$subject,$text)=@_;
     return       return 
 "<a href='/adm/email?compose=individual&recname=$un&recdom=$do'>$link</a>";          '<a href="/adm/email?compose=individual&'.
           'recname='.$username.'&recdom='.$domain.
    '&subject='.&escape($subject).'&text='.&escape($text).'" '.
           'title="'.&mt('Send message').'">'.$link.'</a>';
 }  }
 # --------------------------------------------------------------- Notes Wrapper  # --------------------------------------------------------------- Notes Wrapper
   
Line 1480  sub noteswrapper { Line 2055  sub noteswrapper {
 # ------------------------------------------------------------- Aboutme Wrapper  # ------------------------------------------------------------- Aboutme Wrapper
   
 sub aboutmewrapper {  sub aboutmewrapper {
     my ($link,$username,$domain)=@_;      my ($link,$username,$domain,$target)=@_;
     return "<a href='/adm/$domain/$username/aboutme'>$link</a>";      return '<a href="/adm/'.$domain.'/'.$username.'/aboutme"'.
    ($target?' target="$target"':'').' title="'.&mt('View this users personal page').'">'.$link.'</a>';
 }  }
   
 # ------------------------------------------------------------ Syllabus Wrapper  # ------------------------------------------------------------ Syllabus Wrapper
Line 1492  sub syllabuswrapper { Line 2068  sub syllabuswrapper {
     if ($fontcolor) {       if ($fontcolor) { 
         $linktext='<font color="'.$fontcolor.'">'.$linktext.'</font>';           $linktext='<font color="'.$fontcolor.'">'.$linktext.'</font>'; 
     }      }
     return "<a href='/public/$domain/$coursedir/syllabus'>$linktext</a>";      return qq{<a href="/public/$domain/$coursedir/syllabus">$linktext</a>};
   }
   
   sub track_student_link {
       my ($linktext,$sname,$sdom,$target,$start) = @_;
       my $link ="/adm/trackstudent?";
       my $title = 'View recent activity';
       if (defined($sname) && $sname !~ /^\s*$/ &&
           defined($sdom)  && $sdom  !~ /^\s*$/) {
           $link .= "selected_student=$sname:$sdom";
           $title .= ' of this student';
       } 
       if (defined($target) && $target !~ /^\s*$/) {
           $target = qq{target="$target"};
       } else {
           $target = '';
       }
       if ($start) { $link.='&amp;start='.$start; }
       return qq{<a href="$link" title="$title" $target>$linktext</a>};
 }  }
   
 =pod  =pod
Line 1528  sub languagedescription { Line 2122  sub languagedescription {
     ($supported_language{$code}?' ('.&mt('interface available').')':'');      ($supported_language{$code}?' ('.&mt('interface available').')':'');
 }  }
   
   sub plainlanguagedescription {
       my $code=shift;
       return $language{$code};
   }
   
   sub supportedlanguagecode {
       my $code=shift;
       return $supported_language{$code};
   }
   
 =pod  =pod
   
 =item * copyrightids()   =item * copyrightids() 
Line 1549  returns description of a specified copyr Line 2153  returns description of a specified copyr
 =cut  =cut
   
 sub copyrightdescription {  sub copyrightdescription {
     return $cprtag{shift(@_)};      return &mt($cprtag{shift(@_)});
   }
   
   =pod
   
   =item * source_copyrightids() 
   
   returns list of all source copyrights
   
   =cut
   
   sub source_copyrightids {
       return sort(keys(%scprtag));
   }
   
   =pod
   
   =item * source_copyrightdescription() 
   
   returns description of a specified source copyright id
   
   =cut
   
   sub source_copyrightdescription {
       return &mt($scprtag{shift(@_)});
 }  }
   
 =pod  =pod
Line 1574  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 1589  sub fileembstyle { Line 2218  sub fileembstyle {
     return $fe{lc(shift(@_))};      return $fe{lc(shift(@_))};
 }  }
   
   sub filemimetype {
       return $fm{lc(shift(@_))};
   }
   
   
   sub filecategoryselect {
       my ($name,$value)=@_;
       return &select_form($value,$name,
    '' => &mt('Any category'),
    map { $_,$_ } sort(keys(%category_extensions)));
   }
   
 =pod  =pod
   
 =item * filedescription()   =item * filedescription() 
Line 1598  returns description for a specified file Line 2239  returns description for a specified file
 =cut  =cut
   
 sub filedescription {  sub filedescription {
     return $fd{lc(shift(@_))};      my $file_description = $fd{lc(shift())};
       $file_description =~ s:([\[\]]):~$1:g;
       return &mt($file_description);
 }  }
   
 =pod  =pod
Line 1612  extra formatting Line 2255  extra formatting
   
 sub filedescriptionex {  sub filedescriptionex {
     my $ex=shift;      my $ex=shift;
     return '.'.$ex.' '.$fd{lc($ex)};      my $file_description = $fd{lc($ex)};
       $file_description =~ s:([\[\]]):~$1:g;
       return '.'.$ex.' '.&mt($file_description);
 }  }
   
 # End of .tab access  # End of .tab access
Line 1633  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 1647  sub display_languages { Line 2292  sub display_languages {
   
 sub preferred_languages {  sub preferred_languages {
     my @languages=();      my @languages=();
     if ($ENV{'environment.languages'}) {      if ($env{'course.'.$env{'request.course.id'}.'.languages'}) {
  @languages=split(/\s*(\,|\;|\:)\s*/,$ENV{'environment.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'}) {
    @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 1674  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 1734  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 1757  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>'.$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};
  }   }
  if ($_ =~/$regexp$/ && (defined &$gradesub)) {$value = &$gradesub($value)}   $value=&unescape($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 1808  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 1832  show a snapshot of what student was look Line 2478  show a snapshot of what student was look
 =cut  =cut
   
 sub get_student_view {  sub get_student_view {
   my ($symb,$username,$domain,$courseid,$target) = @_;    my ($symb,$username,$domain,$courseid,$target,$moreenv) = @_;
   my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb);    my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb);
   my (%old,%moreenv);    my (%form);
   my @elements=('symb','courseid','domain','username');    my @elements=('symb','courseid','domain','username');
   foreach my $element (@elements) {    foreach my $element (@elements) {
     $old{$element}=$ENV{'form.grade_'.$element};        $form{'grade_'.$element}=eval '$'.$element #'
     $moreenv{'form.grade_'.$element}=eval '$'.$element #'  
   }    }
   if ($target eq 'tex') {$moreenv{'form.grade_target'} = 'tex';}    if (defined($moreenv)) {
   &Apache::lonnet::appenv(%moreenv);        %form=(%form,%{$moreenv});
   $feedurl=&Apache::lonnet::clutter($feedurl);  
   my $userview=&Apache::lonnet::ssi_body($feedurl);  
   &Apache::lonnet::delenv('form.grade_');  
   foreach my $element (@elements) {  
     $ENV{'form.grade_'.$element}=$old{$element};  
   }    }
     if (defined($target)) { $form{'grade_target'} = $target; }
     $feedurl=&Apache::lonnet::clutter($feedurl);
     my $userview=&Apache::lonnet::ssi_body($feedurl,%form);
   $userview=~s/\<body[^\>]*\>//gi;    $userview=~s/\<body[^\>]*\>//gi;
   $userview=~s/\<\/body\>//gi;    $userview=~s/\<\/body\>//gi;
   $userview=~s/\<html\>//gi;    $userview=~s/\<html\>//gi;
Line 1870  show a snapshot of how student was answe Line 2513  show a snapshot of how student was answe
 sub get_student_answers {  sub get_student_answers {
   my ($symb,$username,$domain,$courseid,%form) = @_;    my ($symb,$username,$domain,$courseid,%form) = @_;
   my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb);    my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb);
   my (%old,%moreenv);    my (%moreenv);
   my @elements=('symb','courseid','domain','username');    my @elements=('symb','courseid','domain','username');
   foreach my $element (@elements) {    foreach my $element (@elements) {
     $old{$element}=$ENV{'form.grade_'.$element};      $moreenv{'grade_'.$element}=eval '$'.$element #'
     $moreenv{'form.grade_'.$element}=eval '$'.$element #'  
   }  
   $moreenv{'form.grade_target'}='answer';  
   &Apache::lonnet::appenv(%moreenv);  
   my $userview=&Apache::lonnet::ssi('/res/'.$feedurl,%form);  
   &Apache::lonnet::delenv('form.grade_');  
   foreach my $element (@elements) {  
     $ENV{'form.grade_'.$element}=$old{$element};  
   }    }
     $moreenv{'grade_target'}='answer';
     %moreenv=(%form,%moreenv);
     my $userview=&Apache::lonnet::ssi('/res/'.$feedurl,%moreenv);
   return $userview;    return $userview;
 }  }
   
Line 1890  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 1898  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)) {
    (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/grades?&command=submission&'.
    'symb='.$symb.'&student='.$uname.
    '&userdom='.$udom.'" '.$target.'>'.$text.'</a>';
   }
   ##############################################
   
   =pod
   
   =item * &pgrdlink()
   
   Inputs: $text $uname $udom $symb $target
   
   Returns: A link to grades.pm such as to see the PGRD view of a student
   
   =cut
   
   ###############################################
   sub pgrdlink {
       my $link=&submlink(@_);
       $link=~s/(&command=submission)/$1&showgrading=yes/;
       return $link;
   }
   ##############################################
   
   =pod
   
   =item * &pprmlink()
   
   Inputs: $text $uname $udom $symb $target
   
   Returns: A link to parmset.pm such as to see the PPRM view of a
   student and a specific resource
   
   =cut
   
   ###############################################
   sub pprmlink {
       my ($text,$uname,$udom,$symb,$target)=@_;
     if (!($uname && $udom)) {      if (!($uname && $udom)) {
  (my $cursymb, my $courseid,$udom,$uname)=   (my $cursymb, my $courseid,$udom,$uname)=
     &Apache::lonxml::whichuser($symb);      &Apache::lonxml::whichuser($symb);
  if (!$symb) { $symb=$cursymb; }   if (!$symb) { $symb=$cursymb; }
     }      }
     if (!$symb) { $symb=&symbread(); }      if (!$symb) { $symb=&Apache::lonnet::symbread(); }
     return '<a href="/adm/grades?symb='.$symb.'&student='.$uname.      $symb=&escape($symb);
  '&userdom='.$udom.'&command=submission">'.$text.'</a>';      if ($target) { $target="target=\"$target\""; }
       return '<a href="/adm/parmset?&command=set&'.
    'symb='.$symb.'&uname='.$uname.
    '&udom='.$udom.'" '.$target.'>'.$text.'</a>';
 }  }
 ##############################################  ##############################################
   
Line 1932  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(
         ($th{'seconds'},$th{'minutes'},$th{'hours'},          ($th{'seconds'},$th{'minutes'},$th{'hours'},
          $th{'day'},$th{'month'}-1,$th{'year'}-1900,0,0,$th{'dlsav'}));           $th{'day'},$th{'month'}-1,$th{'year'}-1900,0,0,-1));
 }  
   
   
 #########################################  
 #  
 # Retro-fixing of un-backward-compatible time format  
   
 sub unsqltime {  
     my $timestamp=shift;  
     if ($timestamp=~/^(\d+)\-(\d+)\-(\d+)\s+(\d+)\:(\d+)\:(\d+)$/) {  
        $timestamp=&maketime(  
    'year'=>$1,'month'=>$2,'day'=>$3,  
            'hours'=>$4,'minutes'=>$5,'seconds'=>$6);  
     }  
     return $timestamp;  
 }  }
   
 #########################################  #########################################
   
 sub findallcourses {  sub findallcourses {
     my %courses=();      my ($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 1969  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 1998  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 2022  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" />';  
     } 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 2047  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 2058  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 2101  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 2111  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);
     unless ($function) {  
  $function='student';      $function = &get_users_function() if (!$function);
         if ($ENV{'request.role'}=~/^(cc|in|ta|ep)/) {      my $img =    &designparm($function.'.img',$domain);
     $function='coordinator';      my $font =   &designparm($function.'.font',$domain);
         }      my $pgbg   = $bgcolor || &designparm($function.'.pgbg',$domain);
  if ($ENV{'request.role'}=~/^(su|dc|ad|li)/) {  
             $function='admin';      my %design = ( 'style'   => 'margin-top: 0px',
         }     'bgcolor' => $pgbg,
         if (($ENV{'request.role'}=~/^(au|ca)/) ||     'text'    => $font,
             ($ENV{'REQUEST_URI'}=~/^(\/priv|\~)/)) {                     'alink'   => &designparm($function.'.alink',$domain),
             $function='author';     'vlink'   => &designparm($function.'.vlink',$domain),
         }     'link'    => &designparm($function.'.link',$domain),);
     }      @$addentries{keys(%design)} = @design{keys(%design)};
     my $img=&designparm($function.'.img',$domain);  
     my $pgbg=&designparm($function.'.pgbg',$domain);  
     my $tabbg=&designparm($function.'.tabbg',$domain);  
     my $font=&designparm($function.'.font',$domain);  
     my $link=&designparm($function.'.link',$domain);  
     my $alink=&designparm($function.'.alink',$domain);  
     my $vlink=&designparm($function.'.vlink',$domain);  
     my $sidebg=&designparm($function.'.sidebg',$domain);  
 # Accessibility font enhance  
     unless ($addentries) { $addentries=''; }  
     if ($ENV{'browser.fontenhance'} eq 'on') {  
  $addentries.=' style="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>".
 <body bgcolor="$pgbg" text="$font" alink="$alink" vlink="$vlink" link="$link"   &Apache::lontexconvert::init_math_support();
 $addentries>  
 END      if ($bodyonly 
     my $upperleft='<img src="http://'.$ENV{'HTTP_HOST'}.':'.   || ($env{'request.state'} eq 'construct' 
                    $lonhttpdPort.$img.'" />';      && $env{'environment.remote'} ne 'off' )) {
     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   }
         return $bodytag.&Apache::lonmenu::menubuttons($forcereg,'web',   return $bodytag;
                                                       $forcereg).      }
                '<table bgcolor="'.$pgbg.'" width="100%" border="0" cellspacing="3" cellpadding="3"><tr><td bgcolor="'.$tabbg.'"><font size="+3" color="'.$font.'"><b>'.$title.  
 '</b></font></td></tr></table>';  
       
       my $roleinfo=(<<ENDROLE);
   <td class="LC_title_bar_who">
   <div class="LC_title_bar_name">
       $env{'environment.firstname'}
       $env{'environment.middlename'}
       $env{'environment.lastname'}
       $env{'environment.generation'}
       &nbsp;
   </div>
   <div class="LC_title_bar_role">
   $role&nbsp;
   </div>
   <div class="LC_title_bar_realm">
   $realm&nbsp;
   </div>
   </td>
   ENDROLE
   
       my $titleinfo = '<span class="LC_title_bar_title">'.$title.'</span>';
       if ($customtitle) {
           $titleinfo = $customtitle;
       }
       #
       # Extra info if you are the DC
       my $dc_info = '';
       if ($env{'user.adv'} && exists($env{'user.role.dc./'.
                           $env{'course.'.$env{'request.course.id'}.
                                    '.domain'}.'/'})) {
           my $cid = $env{'request.course.id'};
           $dc_info.= $cid.' '.$env{'course.'.$cid.'.internal.coursecode'};
           $dc_info =~ 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"><b>$title</b></font>  
 <td bgcolor="$tabbg"  align="right">  
 <font size="2">  
     $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">$role</font>&nbsp;  
 </td></tr>  
 <tr>  
 <td bgcolor="$tabbg" align="right"><font size="2">$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;
   }
   
   
   ###############################################
 ###############################################  ###############################################
   
 sub get_posted_cgi {  =pod
     my $r=shift;  
   =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;
   }
   td.LC_table_cell_checkbox {
     text-align: center;
   }
   
   .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
   
     my $buffer;  =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) = @_;
           
     $r->read($buffer,$r->header_in('Content-length'),0);      my $function = $args->{'function'} || &get_users_function();
     unless ($buffer=~/^(\-+\w+)\s+Content\-Disposition\:\s*form\-data/si) {      my $domain   = $args->{'domain'}   || &determinedomain();
  my @pairs=split(/&/,$buffer);      my $bgcolor  = $args->{'bgcolor'}  || &designparm($function.'.pgbg',$domain);
  my $pair;      my $url = join(':',$env{'user.name'},$env{'user.domain'},
  foreach $pair (@pairs) {     $env{'environment.color.timestamp'},
     my ($name,$value) = split(/=/,$pair);     $function,$domain,$bgcolor);
     $value =~ tr/+/ /;  
     $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;      $url = '/adm/css/'.&escape($url).'.css';
     $name  =~ tr/+/ /;  
     $name  =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;      my $result =
     &add_to_env("form.$name",$value);   '<head>'.
  }   '<link rel="stylesheet" type="text/css" href="'.$url.'" />'.
     } else {   &font_settings().
  my $contentsep=$1;   &Apache::lonhtmlcommon::htmlareaheaders();
  my @lines = split (/\n/,$buffer);  
  my $name='';      if ($args->{'force_register'}) {
  my $value='';   $result .= &Apache::lonmenu::registerurl(1);
  my $fname='';      }
  my $fmime='';  
  my $i;      if (ref($args->{'redirect'})) {
  for ($i=0;$i<=$#lines;$i++) {   my ($time,$url) = @{$args->{'redirect'}};
     if ($lines[$i]=~/^$contentsep/) {   $url = &Apache::lonenc::check_encrypt($url);
  if ($name) {   $env{'internal.head.redirect'} = $url;
     chomp($value);   $result.=<<ADDMETA
     if ($fname) {  <meta http-equiv="pragma" content="no-cache" />
  $ENV{"form.$name.filename"}=$fname;  <meta http-equiv="Refresh" content="$time; url=$url" />
  $ENV{"form.$name.mimetype"}=$fmime;  ADDMETA
     } else {      }
  $value=~s/\s+$//s;      if (!defined($title)) {
     }   $title = 'The LearningOnline Network with CAPA';
     &add_to_env("form.$name",$value);      }
       
       $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
   
   Used by &bodytag to determine the current users primary role.
   Returns either 'student','coordinator','admin', or 'author'.
   
   =cut
   
   ###############################################
   sub get_users_function {
       my $function = 'student';
       if ($env{'request.role'}=~/^(cc|in|ta|ep)/) {
           $function='coordinator';
       }
       if ($env{'request.role'}=~/^(su|dc|ad|li)/) {
           $function='admin';
       }
       if (($env{'request.role'}=~/^(au|ca)/) ||
           ($ENV{'REQUEST_URI'}=~/^(\/priv|\~)/)) {
           $function='author';
       }
       return $function;
   }
   
   ###############################################
   
   =pod
   
   =item check_user_status
   
   Determines current status of supplied role for a
   specific user. Roles can be active, previous or future.
   
   Inputs: 
   user's domain, user's username, course's domain,
   course's number, optional section ID.
   
   Outputs:
   role status: active, previous or future. 
   
   =cut
   
   sub check_user_status {
       my ($udom,$uname,$cdom,$crs,$role,$secgrp) = @_;
       my %userinfo = &Apache::lonnet::dump('roles',$udom,$uname);
       my @uroles = keys %userinfo;
       my $srchstr;
       my $active_chk = 'none';
       if (@uroles > 0) {
           if (($role eq 'cc') || ($secgrp eq '') || (!defined($secgrp))) {
               $srchstr = '/'.$cdom.'/'.$crs.'_'.$role;
           } else {
               $srchstr = '/'.$cdom.'/'.$crs.'/'.$secgrp.'_'.$role;         }
           if (grep/^$srchstr$/,@uroles) {
               my $role_end = 0;
               my $role_start = 0;
               $active_chk = 'active';
               if ($userinfo{$srchstr} =~ m/^($role)_(\d+)/) {
                   $role_end = $2;
                   if ($userinfo{$srchstr} =~ m/^($role)_($role_end)_(\d+)$/) {
                       $role_start = $3;
                   }
               }
               if ($role_start > 0) {
                   if (time < $role_start) {
                       $active_chk = 'future';
                   }
               }
               if ($role_end > 0) {
                   if (time > $role_end) {
                       $active_chk = 'previous';
                   }
               }
           }
       }
       return $active_chk;
   }
   
   ###############################################
   
   =pod
   
   =item get_sections
   
   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}++;
       }
    }
       }
       my %courseroles = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum);
       foreach my $user (sort(keys(%courseroles))) {
    if ($user !~ /^(\w{2})/) { next; }
    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 ($i<$#lines) {              } 
     $i++;              if (defined($$types{'active'})) {
     $lines[$i]=~                  if ($$classlist{$student}[$idx{status}] eq 'Active') {
  /Content\-Disposition\:\s*form\-data\;\s*name\=\"([^\"]+)\"/i;                      push(@{$$users{st}{$student}},'active');
     $name=$1;                      $match = 1;
     $value='';                  }
     if ($lines[$i]=~/filename\=\"([^\"]+)\"/i) {              }
  $fname=$1;              if (defined($$types{'previous'})) {
  if                   if ($$classlist{$student}[$idx{end}] <= $now) {
                             ($lines[$i+1]=~/Content\-Type\:\s*([\w\-\/]+)/i) {                      push(@{$$users{st}{$student}},'previous');
  $fmime=$1;                      $match = 1;
  $i++;                  }
     } else {              }
  $fmime='';              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 '')) {
     } else {                      push(@{$$users{st}{$student}},'future');
  $fname='';                      $match = 1;
  $fmime='';                  }
               }
               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;
     }      }
     $i++;                  }
  }                  if ($uname ne '' && $udom ne '') {
     } else {                      my $status = &check_user_status($udom,$uname,$cdom,$cnum,$role);
  $value.=$lines[$i]."\n";                      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;
   }
   
   sub get_secgrprole_info {
       my ($cdom,$cnum,$needroles,$type)  = @_;
       my %sections_count = &get_sections($cdom,$cnum);
       my @sections =  (sort {$a <=> $b} keys(%sections_count));
       my %curr_groups = &Apache::longroup::coursegroups($cdom,$cnum);
       my @groups = sort(keys(%curr_groups));
       my $allroles = [];
       my $rolehash;
       my $accesshash = {
                        active => 'Currently has access',
                        future => 'Will have future access',
                        previous => 'Previously had access',
                     };
       if ($needroles) {
           $rolehash = {'all' => 'all'};
           my %user_roles = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum);
    if (&Apache::lonnet::error(%user_roles)) {
       undef(%user_roles);
  }   }
           foreach my $item (keys(%user_roles)) {
               my ($role)=split(/\:/,$item,2);
               if ($role eq 'cr') { next; }
               if ($role =~ /^cr/) {
                   $$rolehash{$role} = (split('/',$role))[3];
               } else {
                   $$rolehash{$role} = &Apache::lonnet::plaintext($role,$type);
               }
           }
           foreach my $key (sort(keys(%{$rolehash}))) {
               push(@{$allroles},$key);
           }
           push (@{$allroles},'st');
           $$rolehash{'st'} = &Apache::lonnet::plaintext('st',$type);
     }      }
     $ENV{'request.method'}=$ENV{'REQUEST_METHOD'};      return (\@sections,\@groups,$allroles,$rolehash,$accesshash);
     $r->method_number(M_GET);  
     $r->method('GET');  
     $r->headers_in->unset('Content-length');  
 }  }
   
 =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 2316  returns cache-controlling header code Line 4061  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 2333  specifies header code to not have cache Line 4078  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) = @_;
   unless ($charset) {      if ($r) {
       $charset=&Apache::lonlocal::current_encoding;   #  Note that printout.pl calls this with undef for $r.
   }   &no_cache($r);
   $r->content_type($type.($charset?'; charset='.$charset:''));      }
       if ($env{'browser.mathml'} && $type eq 'text/html') { $type='text/xml'; }
       unless ($charset) {
    $charset=&Apache::lonlocal::current_encoding;
       }
       if ($charset) { $type.='; charset='.$charset; }
       if ($r) {
    $r->content_type($type);
       } else {
    print("Content-type: $type\n\n");
       }
 }  }
   
 =pod  =pod
   
 =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 2361  reference and $value is added to the arr Line 4117  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;
   }    }
 }  }
   
 =pod  =pod
   
   =item * get_env_multiple($name) 
   
   gets $name from the %env hash, it seemlessly handles the cases where multiple
   values may be defined and end up as an array ref.
   
   returns an array of values
   
   =cut
   
   sub get_env_multiple {
       my ($name) = @_;
       my @values;
       if (defined($env{$name})) {
           # exists is it an array
           if (ref($env{$name})) {
               @values=@{ $env{$name} };
           } else {
               $values[0]=$env{$name};
           }
       }
       return(@values);
   }
   
   
   =pod
   
 =back   =back 
   
 =head1 CSV Upload/Handling functions  =head1 CSV Upload/Handling functions
Line 2387  sub add_to_env { Line 4169  sub add_to_env {
 =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 $fh=Apache::File->new('>'.$r->dir_config('lonDaemons').          my $datafile = $r->dir_config('lonDaemons').
  '/tmp/'.$datatoken.'.tmp');                             '/tmp/'.$datatoken.'.tmp';
  print $fh $ENV{'form.upfile'};          if ( open(my $fh,">$datafile") ) {
               print $fh $env{'form.upfile'};
               close($fh);
           }
     }      }
     return $datatoken;      return $datatoken;
 }  }
Line 2414  sub upfile_store { Line 4199  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 2423  sub load_tmp_file { Line 4208  sub load_tmp_file {
     my $r=shift;      my $r=shift;
     my @studentdata=();      my @studentdata=();
     {      {
  my $fh;          my $studentfile = $r->dir_config('lonDaemons').
  if ($fh=Apache::File->new($r->dir_config('lonDaemons').                                '/tmp/'.$env{'form.datatoken'}.'.tmp';
   '/tmp/'.$ENV{'form.datatoken'}.'.tmp')) {          if ( open(my $fh,"<$studentfile") ) {
     @studentdata=<$fh>;              @studentdata=<$fh>;
  }              close($fh);
           }
     }      }
     $ENV{'form.upfile'}=join('',@studentdata);      $env{'form.upfile'}=join('',@studentdata);
 }  }
   
 =pod  =pod
Line 2438  sub load_tmp_file { Line 4224  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 2453  sub upfile_record_sep { Line 4244  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 2494  sub record_sep { Line 4288  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++;
         }          }
     }      }
     return %components;      return %components;
 }  }
   
   ######################################################
   ######################################################
   
 =pod  =pod
   
 =item * upfile_select_html()  =item * upfile_select_html()
   
 return HTML code to select file and specify its type  Return HTML code to select a file from the users machine and specify 
   the file type.
   
 =cut  =cut
   
   ######################################################
   ######################################################
 sub upfile_select_html {  sub upfile_select_html {
     return (<<'ENDUPFORM');      my %Types = (
 <input type="file" name="upfile" size="50" />                   csv   => &mt('CSV (comma separated values, spreadsheet)'),
 <br />Type: <select name="upfiletype">                   space => &mt('Space separated'),
 <option value="csv">CSV (comma separated values, spreadsheet)</option>                   tab   => &mt('Tabulator separated'),
 <option value="space">Space separated</option>  #                 xml   => &mt('HTML/XML'),
 <option value="tab">Tabulator separated</option>                   );
 <option value="xml">HTML/XML</option>      my $Str = '<input type="file" name="upfile" size="50" />'.
 </select>          '<br />Type: <select name="upfiletype">';
 ENDUPFORM      foreach my $type (sort(keys(%Types))) {
           $Str .= '<option value="'.$type.'" >'.$Types{$type}."</option>\n";
       }
       $Str .= "</select>\n";
       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;
 }  }
   
   ######################################################
   ######################################################
   
 =pod  =pod
   
 =item * csv_print_samples($r,$records)  =item * csv_print_samples($r,$records)
Line 2531  Apache Request ref, $records is an array Line 4354  Apache Request ref, $records is an array
   
 =cut  =cut
   
   ######################################################
   ######################################################
 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('Samples<br /><table border="2"><tr>');      $r->print(&mt('Samples').'<br /><table border="2"><tr>');
     foreach (sort({$a <=> $b} keys(%sone))) { $r->print('<th>Column&nbsp;'.($_+1).'</th>'); }      foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) { 
           $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 2553  sub csv_print_samples { Line 4376  sub csv_print_samples {
     $r->print('</tr></table><br />'."\n");      $r->print('</tr></table><br />'."\n");
 }  }
   
   ######################################################
   ######################################################
   
 =pod  =pod
   
 =item * csv_print_select_table($r,$records,$d)  =item * csv_print_select_table($r,$records,$d)
   
 Prints a table to create associations between values and table columns.  Prints a table to create associations between values and table columns.
   
 $r is an Apache Request ref,  $r is an Apache Request ref,
 $records is an arrayref from &Apache::loncommon::upfile_record_sep,  $records is an arrayref from &Apache::loncommon::upfile_record_sep,
 $d is an array of 2 element arrays (internal name, displayed name)  $d is an array of 2 element arrays (internal name, displayed name,defaultcol)
   
 =cut  =cut
   
   ######################################################
   ######################################################
 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('Associate columns with student attributes.'."\n".      $r->print(&mt('Associate columns with student attributes.')."\n".
      '<table border="2"><tr><th>Attribute</th><th>Column</th></tr>'."\n");       '<table border="2"><tr>'.
     foreach (@$d) {                '<th>'.&mt('Attribute').'</th>'.
  my ($value,$display)=@{ $_ };                '<th>'.&mt('Column').'</th></tr>'."\n");
       foreach my $array_ref (@$d) {
    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="'.$_.'">Column '.($_+1).'</option>');      $r->print('<option value="'.$sample.'"'.
                         ($sample eq $defaultcol ? ' selected="selected" ' : '').
                         '>Column '.($sample+1).'</option>');
  }   }
  $r->print('</select></td></tr>'."\n");   $r->print('</select></td></tr>'."\n");
  $i++;   $i++;
Line 2587  sub csv_print_select_table { Line 4420  sub csv_print_select_table {
     return $i;      return $i;
 }  }
   
   ######################################################
   ######################################################
   
 =pod  =pod
   
 =item * csv_samples_select_table($r,$records,$d)  =item * csv_samples_select_table($r,$records,$d)
Line 2599  $d is an array of 2 element arrays (inte Line 4435  $d is an array of 2 element arrays (inte
   
 =cut  =cut
   
   ######################################################
   ######################################################
 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>'.
                 &mt('Field').'</th><th>'.&mt('Samples').'</th></tr>');
   
     $r->print('<table border=2><tr><th>Field</th><th>Samples</th></tr>');      foreach my $key (sort(keys(%{ $samples->[0] }))) {
     %sone=&record_sep($$records[0]);   $r->print('<tr><td><select name="f'.$i.'"'.
     if (defined($$records[1])) {%stwo=&record_sep($$records[1]);}  
     if (defined($$records[2])) {%sthree=&record_sep($$records[2]);}  
   
     foreach (sort keys %sone) {  
  $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)=@{ $_ };      my ($value,$display,$defaultcol)=@{ $option };
     $r->print('<option value='.$value.'>'.$display.'</option>');      $r->print('<option value="'.$value.'"'.
                         ($i eq $defaultcol ? ' selected="selected" ':'').'>'.
                         $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 2627  sub csv_samples_select_table { Line 4467  sub csv_samples_select_table {
     return($i);      return($i);
 }  }
   
   ######################################################
   ######################################################
   
 =pod  =pod
   
 =item clean_excel_name($name)  =item clean_excel_name($name)
Line 2635  Returns a replacement for $name which do Line 4478  Returns a replacement for $name which do
   
 =cut  =cut
   
   ######################################################
   ######################################################
 sub clean_excel_name {  sub clean_excel_name {
     my ($name) = @_;      my ($name) = @_;
     $name =~ s/[:\*\?\/\\]//g;      $name =~ s/[:\*\?\/\\]//g;
Line 2665  sub check_if_partid_hidden { Line 4510  sub check_if_partid_hidden {
     my ($id,$symb,$udom,$uname) = @_;      my ($id,$symb,$udom,$uname) = @_;
     my $hiddenparts=&Apache::lonnet::EXT('resource.0.hiddenparts',      my $hiddenparts=&Apache::lonnet::EXT('resource.0.hiddenparts',
  $symb,$udom,$uname);   $symb,$udom,$uname);
       my $truth=1;
       #if the string starts with !, then the list is the list to show not hide
       if ($hiddenparts=~s/^\s*!//) { $truth=undef; }
     my @hiddenlist=split(/,/,$hiddenparts);      my @hiddenlist=split(/,/,$hiddenparts);
     foreach my $checkid (@hiddenlist) {      foreach my $checkid (@hiddenlist) {
  if ($checkid =~ /^\s*\Q$id\E\s*$/) { return 1; }   if ($checkid =~ /^\s*\Q$id\E\s*$/) { return $truth; }
     }      }
     return undef;      return !$truth;
   }
   
   
   ############################################################
   ############################################################
   
   =pod
   
   =back 
   
   =head1 cgi-bin script and graphing routines
   
   =over 4
   
   =item get_cgi_id
   
   Inputs: none
   
   Returns an id which can be used to pass environment variables
   to various cgi-bin scripts.  These environment variables will
   be removed from the users environment after a given time by
   the routine &Apache::lonnet::transfer_profile_to_env.
   
   =cut
   
   ############################################################
   ############################################################
   my $uniq=0;
   sub get_cgi_id {
       $uniq=($uniq+1)%100000;
       return (time.'_'.$$.'_'.$uniq);
 }  }
   
 ############################################################  ############################################################
Line 2679  sub check_if_partid_hidden { Line 4558  sub check_if_partid_hidden {
   
 =item DrawBarGraph  =item DrawBarGraph
   
   Facilitates the plotting of data in a (stacked) bar graph.
   Puts plot definition data into the users environment in order for 
   graph.png to plot it.  Returns an <img> tag for the plot.
   The bars on the plot are labeled '1','2',...,'n'.
   
   Inputs:
   
   =over 4
   
   =item $Title: string, the title of the plot
   
   =item $xlabel: string, text describing the X-axis of the plot
   
   =item $ylabel: string, text describing the Y-axis of the plot
   
   =item $Max: scalar, the maximum Y value to use in the plot
   If $Max is < any data point, the graph will not be rendered.
   
   =item $colors: array ref holding the colors to be used for the data sets when
   they are plotted.  If undefined, default values will be used.
   
   =item $labels: array ref holding the labels to use on the x-axis for the bars.
   
   =item @Values: An array of array references.  Each array reference holds data
   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
   
   Returns:
   
   An <img> tag which references graph.png and the appropriate identifying
   information for the plot.
   
 =cut  =cut
   
 ############################################################  ############################################################
 ############################################################  ############################################################
 sub DrawBarGraph {  sub DrawBarGraph {
     my ($Title,$xlabel,$ylabel,$Max,$colors,@Values)=@_;      my ($Title,$xlabel,$ylabel,$Max,$colors,$labels,@Values)=@_;
     #      #
     if (! defined($colors)) {      if (! defined($colors)) {
         $colors = ['#33ff00',           $colors = ['#33ff00', 
Line 2693  sub DrawBarGraph { Line 4607  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 = time.'_'.int(rand(1000));      my $identifier = &get_cgi_id();
       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) {
         next if (! ref($array));          next if (! ref($array));
         $ValuesHash{'cgi.'.$identifier.'.data.'.$NumSets++} =           $ValuesHash{$id.'.data.'.$NumSets++} = 
             join(',',@$array);              join(',',@$array);
     }      }
     #      #
     $Title  = '' if (! defined($Title));      my ($height,$width,$xskip,$bar_width) = (200,120,1,15);
     $xlabel = '' if (! defined($xlabel));      if ($NumBars < 3) {
     $ylabel = '' if (! defined($ylabel));          $width = 120+$NumBars*32;
     $Title  = &Apache::lonnet::escape($Title);          $xskip = 1;
     $xlabel = &Apache::lonnet::escape($xlabel);          $bar_width = 30;
     $ylabel = &Apache::lonnet::escape($ylabel);      } elsif ($NumBars < 5) {
           $width = 120+$NumBars*20;
           $xskip = 1;
           $bar_width = 20;
       } elsif ($NumBars < 10) {
           $width = 120+$NumBars*15;
           $xskip = 1;
           $bar_width = 15;
       } elsif ($NumBars <= 25) {
           $width = 120+$NumBars*11;
           $xskip = 5;
           $bar_width = 8;
       } elsif ($NumBars <= 50) {
           $width = 120+$NumBars*8;
           $xskip = 5;
           $bar_width = 4;
       } else {
           $width = 120+$NumBars*8;
           $xskip = 5;
           $bar_width = 4;
       }
     #      #
     $Max = 1 if ($Max < 1);      $Max = 1 if ($Max < 1);
     if ( int($Max) < $Max ) {      if ( int($Max) < $Max ) {
         $Max++;          $Max++;
         $Max = int($Max);          $Max = int($Max);
     }      }
       $Title  = '' if (! defined($Title));
       $xlabel = '' if (! defined($xlabel));
       $ylabel = '' if (! defined($ylabel));
       $ValuesHash{$id.'.title'}    = &escape($Title);
       $ValuesHash{$id.'.xlabel'}   = &escape($xlabel);
       $ValuesHash{$id.'.ylabel'}   = &escape($ylabel);
       $ValuesHash{$id.'.y_max_value'} = $Max;
       $ValuesHash{$id.'.NumBars'}  = $NumBars;
       $ValuesHash{$id.'.NumSets'}  = $NumSets;
       $ValuesHash{$id.'.PlotType'} = 'bar';
       $ValuesHash{$id.'.Colors'}   = join(',',@{$colors});
       $ValuesHash{$id.'.height'}   = $height;
       $ValuesHash{$id.'.width'}    = $width;
       $ValuesHash{$id.'.xskip'}    = $xskip;
       $ValuesHash{$id.'.bar_width'} = $bar_width;
       $ValuesHash{$id.'.labels'} = join(',',@Labels);
       #
       # Deal with other parameters
       while (my ($key,$value) = each(%$extra_settings)) {
           $ValuesHash{$id.'.'.$key} = $value;
       }
       #
       &Apache::lonnet::appenv(%ValuesHash);
       return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';
   }
   
   ############################################################
   ############################################################
   
   =pod
   
   =item DrawXYGraph
   
   Facilitates the plotting of data in an XY graph.
   Puts plot definition data into the users environment in order for 
   graph.png to plot it.  Returns an <img> tag for the plot.
   
   Inputs:
   
   =over 4
   
   =item $Title: string, the title of the plot
   
   =item $xlabel: string, text describing the X-axis of the plot
   
   =item $ylabel: string, text describing the Y-axis of the plot
   
   =item $Max: scalar, the maximum Y value to use in the plot
   If $Max is < any data point, the graph will not be rendered.
   
   =item $colors: Array ref containing the hex color codes for the data to be 
   plotted in.  If undefined, default values will be used.
   
   =item $Xlabels: Array ref containing the labels to be used for the X-axis.
   
   =item $Ydata: Array ref containing Array refs.  
   Each of the contained arrays will be plotted as a separate curve.
   
   =item %Values: hash indicating or overriding any default values which are 
   passed to graph.png.  
   Possible values are: width, xskip, x_ticks, x_tick_offset, among others.
   
   =back
   
   Returns:
   
   An <img> tag which references graph.png and the appropriate identifying
   information for the plot.
   
   =cut
   
   ############################################################
   ############################################################
   sub DrawXYGraph {
       my ($Title,$xlabel,$ylabel,$Max,$colors,$Xlabels,$Ydata,%Values)=@_;
       #
       # Create the identifier for the graph
       my $identifier = &get_cgi_id();
       my $id = 'cgi.'.$identifier;
       #
       $Title  = '' if (! defined($Title));
       $xlabel = '' if (! defined($xlabel));
       $ylabel = '' if (! defined($ylabel));
       my %ValuesHash = 
           (
            $id.'.title'  => &escape($Title),
            $id.'.xlabel' => &escape($xlabel),
            $id.'.ylabel' => &escape($ylabel),
            $id.'.y_max_value'=> $Max,
            $id.'.labels'     => join(',',@$Xlabels),
            $id.'.PlotType'   => 'XY',
            );
       #
       if (defined($colors) && ref($colors) eq 'ARRAY') {
           $ValuesHash{$id.'.Colors'}   = join(',',@{$colors});
       }
       #
       if (! ref($Ydata) || ref($Ydata) ne 'ARRAY') {
           return '';
       }
       my $NumSets=1;
       foreach my $array (@{$Ydata}){
           next if (! ref($array));
           $ValuesHash{$id.'.data.'.$NumSets++} = join(',',@$array);
       }
       $ValuesHash{$id.'.NumSets'} = $NumSets-1;
       #
       # Deal with other parameters
       while (my ($key,$value) = each(%Values)) {
           $ValuesHash{$id.'.'.$key} = $value;
       }
       #
       &Apache::lonnet::appenv(%ValuesHash);
       return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';
   }
   
   ############################################################
   ############################################################
   
   =pod
   
   =item DrawXYYGraph
   
   Facilitates the plotting of data in an XY graph with two Y axes.
   Puts plot definition data into the users environment in order for 
   graph.png to plot it.  Returns an <img> tag for the plot.
   
   Inputs:
   
   =over 4
   
   =item $Title: string, the title of the plot
   
   =item $xlabel: string, text describing the X-axis of the plot
   
   =item $ylabel: string, text describing the Y-axis of the plot
   
   =item $colors: Array ref containing the hex color codes for the data to be 
   plotted in.  If undefined, default values will be used.
   
   =item $Xlabels: Array ref containing the labels to be used for the X-axis.
   
   =item $Ydata1: The first data set
   
   =item $Min1: The minimum value of the left Y-axis
   
   =item $Max1: The maximum value of the left Y-axis
   
   =item $Ydata2: The second data set
   
   =item $Min2: The minimum value of the right Y-axis
   
   =item $Max2: The maximum value of the left Y-axis
   
   =item %Values: hash indicating or overriding any default values which are 
   passed to graph.png.  
   Possible values are: width, xskip, x_ticks, x_tick_offset, among others.
   
   =back
   
   Returns:
   
   An <img> tag which references graph.png and the appropriate identifying
   information for the plot.
   
   =cut
   
   ############################################################
   ############################################################
   sub DrawXYYGraph {
       my ($Title,$xlabel,$ylabel,$colors,$Xlabels,$Ydata1,$Min1,$Max1,
                                           $Ydata2,$Min2,$Max2,%Values)=@_;
       #
       # Create the identifier for the graph
       my $identifier = &get_cgi_id();
       my $id = 'cgi.'.$identifier;
       #
       $Title  = '' if (! defined($Title));
       $xlabel = '' if (! defined($xlabel));
       $ylabel = '' if (! defined($ylabel));
       my %ValuesHash = 
           (
            $id.'.title'  => &escape($Title),
            $id.'.xlabel' => &escape($xlabel),
            $id.'.ylabel' => &escape($ylabel),
            $id.'.labels' => join(',',@$Xlabels),
            $id.'.PlotType' => 'XY',
            $id.'.NumSets' => 2,
            $id.'.two_axes' => 1,
            $id.'.y1_max_value' => $Max1,
            $id.'.y1_min_value' => $Min1,
            $id.'.y2_max_value' => $Max2,
            $id.'.y2_min_value' => $Min2,
            );
       #
       if (defined($colors) && ref($colors) eq 'ARRAY') {
           $ValuesHash{$id.'.Colors'}   = join(',',@{$colors});
       }
       #
       if (! ref($Ydata1) || ref($Ydata1) ne 'ARRAY' ||
           ! ref($Ydata2) || ref($Ydata2) ne 'ARRAY'){
           return '';
       }
       my $NumSets=1;
       foreach my $array ($Ydata1,$Ydata2){
           next if (! ref($array));
           $ValuesHash{$id.'.data.'.$NumSets++} = join(',',@$array);
       }
       #
       # Deal with other parameters
       while (my ($key,$value) = each(%Values)) {
           $ValuesHash{$id.'.'.$key} = $value;
       }
     #      #
     &Apache::lonnet::appenv('cgi.'.$identifier.'.title'   => $Title,      &Apache::lonnet::appenv(%ValuesHash);
                             'cgi.'.$identifier.'.xlabel'  => $xlabel,  
                             'cgi.'.$identifier.'.ylabel'  => $ylabel,  
                             'cgi.'.$identifier.'.Max'     => $Max,  
                             'cgi.'.$identifier.'.NumBars' => $NumBars,  
                             'cgi.'.$identifier.'.NumSets' => $NumSets,  
                             'cgi.'.$identifier.'.Colors'  => join(',',@{$colors}),  
                             %ValuesHash);  
     return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';      return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';
 }  }
   
Line 2736  sub DrawBarGraph { Line 4892  sub DrawBarGraph {
   
 =pod  =pod
   
   =back 
   
   =head1 Statistics helper routines?  
   
   Bad place for them but what the hell.
   
   =over 4
   
   =item &chartlink
   
   Returns a link to the chart for a specific student.  
   
   Inputs:
   
   =over 4
   
   =item $linktext: The text of the link
   
   =item $sname: The students username
   
   =item $sdomain: The students domain
   
   =back
   
   =back
   
   =cut
   
   ############################################################
   ############################################################
   sub chartlink {
       my ($linktext, $sname, $sdomain) = @_;
       my $link = '<a href="/adm/statistics?reportSelected=student_assessment'.
           '&amp;SelectedStudent='.&escape($sname.':'.$sdomain).
           '&amp;chartoutputmode='.HTML::Entities::encode('html, with all links').
          '">'.$linktext.'</a>';
   }
   
   #######################################################
   #######################################################
   
   =pod
   
   =head1 Course Environment Routines
   
   =over 4
   
   =item &restore_course_settings 
   
   =item &store_course_settings
   
   Restores/Store indicated form parameters from the course environment.
   Will not overwrite existing values of the form parameters.
   
   Inputs: 
   a scalar describing the data (e.g. 'chart', 'problem_analysis')
   
   a hash ref describing the data to be stored.  For example:
      
   %Save_Parameters = ('Status' => 'scalar',
       'chartoutputmode' => 'scalar',
       'chartoutputdata' => 'scalar',
       'Section' => 'array',
       'Group' => 'array',
       'StudentData' => 'array',
       'Maps' => 'array');
   
   Returns: both routines return nothing
   
   =cut
   
   #######################################################
   #######################################################
   sub store_course_settings {
       # save to the environment
       # appenv the same items, just to be safe
       my $courseid = $env{'request.course.id'};
       my $udom  = $env{'user.domain'};
       my $uname = $env{'user.name'};
       my ($prefix,$Settings) = @_;
       my %SaveHash;
       my %AppHash;
       while (my ($setting,$type) = each(%$Settings)) {
           my $basename = join('.','internal',$courseid,$prefix,$setting);
           my $envname = 'environment.'.$basename;
           if (exists($env{'form.'.$setting})) {
               # Save this value away
               if ($type eq 'scalar' &&
                   (! exists($env{$envname}) || 
                    $env{$envname} ne $env{'form.'.$setting})) {
                   $SaveHash{$basename} = $env{'form.'.$setting};
                   $AppHash{$envname}   = $env{'form.'.$setting};
               } elsif ($type eq 'array') {
                   my $stored_form;
                   if (ref($env{'form.'.$setting})) {
                       $stored_form = join(',',
                                           map {
                                               &escape($_);
                                           } sort(@{$env{'form.'.$setting}}));
                   } else {
                       $stored_form = 
                           &escape($env{'form.'.$setting});
                   }
                   # Determine if the array contents are the same.
                   if ($stored_form ne $env{$envname}) {
                       $SaveHash{$basename} = $stored_form;
                       $AppHash{$envname}   = $stored_form;
                   }
               }
           }
       }
       my $put_result = &Apache::lonnet::put('environment',\%SaveHash,
                                             $udom,$uname);
       if ($put_result !~ /^(ok|delayed)/) {
           &Apache::lonnet::logthis('unable to save form parameters, '.
                                    'got error:'.$put_result);
       }
       # Make sure these settings stick around in this session, too
       &Apache::lonnet::appenv(%AppHash);
       return;
   }
   
   sub restore_course_settings {
       my $courseid = $env{'request.course.id'};
       my ($prefix,$Settings) = @_;
       while (my ($setting,$type) = each(%$Settings)) {
           next if (exists($env{'form.'.$setting}));
           my $envname = 'environment.internal.'.$courseid.'.'.$prefix.
               '.'.$setting;
           if (exists($env{$envname})) {
               if ($type eq 'scalar') {
                   $env{'form.'.$setting} = $env{$envname};
               } elsif ($type eq 'array') {
                   $env{'form.'.$setting} = [ 
                                              map { 
                                                  &unescape($_); 
                                              } split(',',$env{$envname})
                                              ];
               }
           }
       }
   }
   
   ############################################################
   ############################################################
   
   sub course_type {
       my ($cid) = @_;
       if (!defined($cid)) {
           $cid = $env{'request.course.id'};
       }
       if (defined($env{'course.'.$cid.'type'})) {
           return $env{'course.'.$cid.'type'};
       } else {
           return 'Course';
       }
   }
   
   sub icon {
       my ($file)=@_;
       my $curfext = (split(/\./,$file))[-1];
       my $iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/unknown.gif';
       my $embstyle = &Apache::loncommon::fileembstyle($curfext);
       if (!(!defined($embstyle) || $embstyle eq 'unk' || $embstyle eq 'hdn')) {
    if (-e  $Apache::lonnet::perlvar{'lonDocRoot'}.'/'.
             $Apache::lonnet::perlvar{'lonIconsURL'}.'/'.
               $curfext.".gif") {
       $iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/'.
    $curfext.".gif";
    }
       }
       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
   
 =back  =back
   
 =cut  =cut
Removed from v.1.134  
changed lines
  Added in v.1.385

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