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

Diff for /loncom/interface/loncommon.pm between versions 1.300 and 1.356

version 1.300, 2005/12/01 23:04:08 version 1.356, 2006/04/26 15:29:51
Line 58  use strict; Line 58  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::lonmenu();  use Apache::lonmenu();
 use Apache::lonlocal;  use Apache::lonlocal;
 use HTML::Entities;  use HTML::Entities;
   use Apache::lonhtmlcommon();
   use Apache::loncoursedata();
   use Apache::lontexconvert();
   
 my $readit;  my $readit;
   
Line 74  my %language; Line 76  my %language;
 my %supported_language;  my %supported_language;
 my %cprtag;  my %cprtag;
 my %scprtag;  my %scprtag;
 my %fe; my %fd;  my %fe; my %fd; my %fm;
 my %category_extensions;  my %category_extensions;
   
 # ---------------------------------------------- Designs  # ---------------------------------------------- Designs
Line 105  BEGIN { Line 107  BEGIN {
         my $langtabfile = $Apache::lonnet::perlvar{'lonTabDir'}.          my $langtabfile = $Apache::lonnet::perlvar{'lonTabDir'}.
                                    '/language.tab';                                     '/language.tab';
         if ( open(my $fh,"<$langtabfile") ) {          if ( open(my $fh,"<$langtabfile") ) {
             while (<$fh>) {              while (my $line = <$fh>) {
                 next if /^\#/;                  next if ($line=~/^\#/);
                 chomp;                  chomp($line);
                 my ($key,$two,$country,$three,$enc,$val,$sup)=(split(/\t/,$_));                  my ($key,$two,$country,$three,$enc,$val,$sup)=(split(/\t/,$line));
                 $language{$key}=$val.' - '.$enc;                  $language{$key}=$val.' - '.$enc;
                 if ($sup) {                  if ($sup) {
                     $supported_language{$key}=$sup;                      $supported_language{$key}=$sup;
Line 122  BEGIN { Line 124  BEGIN {
         my $copyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.          my $copyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.
                                   '/copyright.tab';                                    '/copyright.tab';
         if ( open (my $fh,"<$copyrightfile") ) {          if ( open (my $fh,"<$copyrightfile") ) {
             while (<$fh>) {              while (my $line = <$fh>) {
                 next if /^\#/;                  next if ($line=~/^\#/);
                 chomp;                  chomp($line);
                 my ($key,$val)=(split(/\s+/,$_,2));                  my ($key,$val)=(split(/\s+/,$line,2));
                 $cprtag{$key}=$val;                  $cprtag{$key}=$val;
             }              }
             close($fh);              close($fh);
         }          }
     }      }
 # ------------------------------------------------------------------ source copyrights  # ----------------------------------------------------------- source copyrights
     {      {
         my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.          my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.
                                   '/source_copyright.tab';                                    '/source_copyright.tab';
         if ( open (my $fh,"<$sourcecopyrightfile") ) {          if ( open (my $fh,"<$sourcecopyrightfile") ) {
             while (<$fh>) {              while (my $line = <$fh>) {
                 next if /^\#/;                  next if ($line =~ /^\#/);
                 chomp;                  chomp($line);
                 my ($key,$val)=(split(/\s+/,$_,2));                  my ($key,$val)=(split(/\s+/,$line,2));
                 $scprtag{$key}=$val;                  $scprtag{$key}=$val;
             }              }
             close($fh);              close($fh);
Line 157  BEGIN { Line 159  BEGIN {
  {   {
     my $designfile = $designdir.'/'.$filename;      my $designfile = $designdir.'/'.$filename;
     if ( open (my $fh,"<$designfile") ) {      if ( open (my $fh,"<$designfile") ) {
  while (<$fh>) {   while (my $line = <$fh>) {
     next if /^\#/;      next if ($line =~ /^\#/);
     chomp;      chomp($line);
     my ($key,$val)=(split(/\=/,$_));      my ($key,$val)=(split(/\=/,$line));
     if ($val) { $designhash{$domain.'.'.$key}=$val; }      if ($val) { $designhash{$domain.'.'.$key}=$val; }
  }   }
  close($fh);   close($fh);
Line 176  BEGIN { Line 178  BEGIN {
         my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}.          my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}.
                                   '/filecategories.tab';                                    '/filecategories.tab';
         if ( open (my $fh,"<$categoryfile") ) {          if ( open (my $fh,"<$categoryfile") ) {
             while (<$fh>) {      while (my $line = <$fh>) {
                 next if /^\#/;   next if ($line =~ /^\#/);
                 chomp;   chomp($line);
                 my ($extension,$category)=(split(/\s+/,$_,2));                  my ($extension,$category)=(split(/\s+/,$line,2));
                 push @{$category_extensions{lc($category)}},$extension;                  push @{$category_extensions{lc($category)}},$extension;
             }              }
             close($fh);              close($fh);
Line 191  BEGIN { Line 193  BEGIN {
         my $typesfile = $Apache::lonnet::perlvar{'lonTabDir'}.          my $typesfile = $Apache::lonnet::perlvar{'lonTabDir'}.
                '/filetypes.tab';                 '/filetypes.tab';
         if ( open (my $fh,"<$typesfile") ) {          if ( open (my $fh,"<$typesfile") ) {
             while (<$fh>) {              while (my $line = <$fh>) {
                 next if (/^\#/);   next if ($line =~ /^\#/);
                 chomp;   chomp($line);
                 my ($ending,$emb,$descr)=split(/\s+/,$_,3);                  my ($ending,$emb,$mime,$descr)=split(/\s+/,$line,4);
                 if ($descr ne '') {                  if ($descr ne '') {
                     $fe{$ending}=lc($emb);                      $fe{$ending}=lc($emb);
                     $fd{$ending}=$descr;                      $fd{$ending}=$descr;
                       if ($mime ne 'unk') { $fm{$ending}=$mime; }
                 }                  }
             }              }
             close($fh);              close($fh);
Line 331  sub storeresurl { Line 334  sub storeresurl {
 sub studentbrowser_javascript {  sub studentbrowser_javascript {
    unless (     unless (
             (($env{'request.course.id'}) &&               (($env{'request.course.id'}) && 
              (&Apache::lonnet::allowed('srm',$env{'request.course.id'})))               (&Apache::lonnet::allowed('srm',$env{'request.course.id'})
         || &Apache::lonnet::allowed('srm',$env{'request.course.id'}.
     '/'.$env{'request.course.sec'})
         ))
          || ($env{'request.role'}=~/^(au|dc|su)/)           || ($env{'request.role'}=~/^(au|dc|su)/)
           ) { return ''; }              ) { return ''; }  
    return (<<'ENDSTDBRW');     return (<<'ENDSTDBRW');
Line 362  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.
Line 699  sub help_open_menu { Line 707  sub help_open_menu {
     my $origurl = $ENV{'REQUEST_URI'};      my $origurl = $ENV{'REQUEST_URI'};
     $origurl=~s|^/~|/priv/|;      $origurl=~s|^/~|/priv/|;
     my $timestamp = time;      my $timestamp = time;
     foreach (\$color,\$function,\$topic,\$component_help,\$faq,\$bug,\$origurl) {      foreach my $datum (\$color,\$function,\$topic,\$component_help,\$faq,
         $$_ = &Apache::lonnet::escape($$_);         \$bug,\$origurl) {
           $$datum = &Apache::lonnet::escape($$datum);
     }      }
     if (!$stayOnPage) {      if (!$stayOnPage) {
          $link = "javascript:helpMenu('open')";           $link = "javascript:helpMenu('open')";
Line 716  sub help_open_menu { Line 725  sub help_open_menu {
   "<td bgcolor='#CC6600'><a href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";    "<td bgcolor='#CC6600'><a href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";
     }      }
     my $nothing=&Apache::lonhtmlcommon::javascript_nothing();      my $nothing=&Apache::lonhtmlcommon::javascript_nothing();
     my $html=&Apache::lonxml::xmlbegin();  
     my $helpicon=&lonhttpdurl("/adm/lonIcons/helpgateway.gif");      my $helpicon=&lonhttpdurl("/adm/lonIcons/helpgateway.gif");
       my $start_page =
           &Apache::loncommon::start_page('Help Menu', undef,
          {'frameset'    => 1,
    'js_ready'    => 1,
    'add_entries' => {
       'border' => '0',
       'rows'   => "105,*",},});
       my $end_page =
           &Apache::loncommon::end_page({'frameset' => 1,
         'js_ready' => 1,});
   
     $template .= <<"ENDTEMPLATE";      $template .= <<"ENDTEMPLATE";
  <script type="text/javascript">   <script type="text/javascript">
 // <!-- BEGIN LON-CAPA Internal  // <!-- BEGIN LON-CAPA Internal
Line 741  function helpMenu(target) { Line 760  function helpMenu(target) {
     return;      return;
 }  }
 function writeHelp(caller) {  function writeHelp(caller) {
     caller.document.writeln('$html<head><title>LON-CAPA Help Menu</title><meta http-equiv="pragma" content="no-cache"></head>')      caller.document.writeln('$start_page<frame name="bannerframe"  src="$banner_link" /><frame name="bodyframe" src="$details_link" /> $end_page')
     caller.document.writeln("<frameset rows='105,*' border='0'><frame name='bannerframe'  src='$banner_link'><frame name='bodyframe' src='$details_link'></frameset>")  
     caller.document.writeln("</html>")  
     caller.document.close()      caller.document.close()
     caller.focus()      caller.focus()
 }  }
Line 1137  sub get_domains { Line 1154  sub get_domains {
     # The code below was stolen from "The Perl Cookbook", p 102, 1st ed.      # The code below was stolen from "The Perl Cookbook", p 102, 1st ed.
     my @domains;      my @domains;
     my %seen;      my %seen;
     foreach (sort values(%Apache::lonnet::hostdom)) {      foreach my $dom (sort(values(%Apache::lonnet::hostdom))) {
  push (@domains,$_) unless $seen{$_}++;   push(@domains,$dom) unless $seen{$dom}++;
     }      }
     return @domains;      return @domains;
 }  }
Line 1192  sub multiple_select_form { Line 1209  sub multiple_select_form {
     my @order = ref($order) ? @$order      my @order = ref($order) ? @$order
                             : sort(keys(%$hash));                              : sort(keys(%$hash));
     foreach my $key (@order) {      foreach my $key (@order) {
         $output.='<option value="'.$key.'" ';          $output.='<option value="'.&HTML::Entities::encode($key,'"<>&').'" ';
         $output.='selected="selected" ' if ($selected{$key});          $output.='selected="selected" ' if ($selected{$key});
         $output.='>'.$hash->{$key}."</option>\n";          $output.='>'.$hash->{$key}."</option>\n";
     }      }
Line 1222  sub select_form { Line 1239  sub select_form {
     } else {      } else {
  @keys=sort(keys(%hash));   @keys=sort(keys(%hash));
     }      }
     foreach (@keys) {      foreach my $key (@keys) {
         $selectform.="<option value=\"$_\" ".          $selectform.=
             ($_ eq $def ? 'selected="selected" ' : '').      '<option value="'.&HTML::Entities::encode($key,'"<>&').'" '.
                 ">".&mt($hash{$_})."</option>\n";              ($key eq $def ? 'selected="selected" ' : '').
                   ">".&mt($hash{$key})."</option>\n";
     }      }
     $selectform.="</select>";      $selectform.="</select>";
     return $selectform;      return $selectform;
Line 1289  sub select_dom_form { Line 1307  sub select_dom_form {
     my @domains = get_domains();      my @domains = get_domains();
     if ($includeempty) { @domains=('',@domains); }      if ($includeempty) { @domains=('',@domains); }
     my $selectdomain = "<select name=\"$name\" size=\"1\">\n";      my $selectdomain = "<select name=\"$name\" size=\"1\">\n";
     foreach (@domains) {      foreach my $dom (@domains) {
         $selectdomain.="<option value=\"$_\" ".          $selectdomain.="<option value=\"$dom\" ".
             ($_ eq $defdom ? 'selected="selected" ' : '').              ($dom eq $defdom ? 'selected="selected" ' : '').
                 ">$_</option>\n";                  ">$dom</option>\n";
     }      }
     $selectdomain.="</select>";      $selectdomain.="</select>";
     return $selectdomain;      return $selectdomain;
Line 1314  given $domain. Line 1332  given $domain.
 sub get_library_servers {  sub get_library_servers {
     my $domain = shift;      my $domain = shift;
     my %library_servers;      my %library_servers;
     foreach (keys(%Apache::lonnet::libserv)) {      foreach my $hostid (keys(%Apache::lonnet::libserv)) {
         if ($Apache::lonnet::hostdom{$_} eq $domain) {          if ($Apache::lonnet::hostdom{$hostid} eq $domain) {
             $library_servers{$_} = $Apache::lonnet::hostname{$_};              $library_servers{$hostid} = $Apache::lonnet::hostname{$hostid};
         }          }
     }      }
     return %library_servers;      return %library_servers;
Line 1338  sub home_server_option_list { Line 1356  sub home_server_option_list {
     my $domain = shift;      my $domain = shift;
     my %servers = &get_library_servers($domain);      my %servers = &get_library_servers($domain);
     my $result = '';      my $result = '';
     foreach (sort keys(%servers)) {      foreach my $hostid (sort(keys(%servers))) {
         $result.=          $result.=
             '<option value="'.$_.'">'.$_.' '.$servers{$_}."</option>\n";              '<option value="'.$hostid.'">'.
       $hostid.' '.$servers{$hostid}."</option>\n";
     }      }
     return $result;      return $result;
 }  }
Line 1830  sub initialize_keywords { Line 1849  sub initialize_keywords {
     }      }
     untie %thesaurus_db;      untie %thesaurus_db;
     # Remove special values from %Keywords.      # Remove special values from %Keywords.
     foreach ('total.count','average.count') {      foreach my $value ('total.count','average.count') {
         delete($Keywords{$_}) if (exists($Keywords{$_}));          delete($Keywords{$value}) if (exists($Keywords{$value}));
     }      }
     return 1;      return 1;
 }  }
Line 1887  sub get_related_words { Line 1906  sub get_related_words {
     }       } 
     my @Words=();      my @Words=();
     if (exists($thesaurus_db{$keyword})) {      if (exists($thesaurus_db{$keyword})) {
         $_ = $thesaurus_db{$keyword};   # The first element is the number of times
         (undef,@Words) = split/:/;  # The first element is the number of times   # the word appears.  We do not need it now.
                                     # the word appears.  We do not need it now.   (undef,@Words) = (split(/:/,$thesaurus_db{$keyword}));
         for (my $i=0;$i<=$#Words;$i++) {          for (my $i=0;$i<=$#Words;$i++) {
             ($Words[$i],undef)= split/\,/,$Words[$i];              ($Words[$i],undef)= split(/\,/,$Words[$i]);
         }          }
     }      }
     untie %thesaurus_db;      untie %thesaurus_db;
Line 1932  sub plainname { Line 1951  sub plainname {
     $name=~s/^\s+//;      $name=~s/^\s+//;
     $name=~s/\s+$//;      $name=~s/\s+$//;
     $name=~s/\s+/ /g;      $name=~s/\s+/ /g;
     if ($name !~ /\S/) { $name=$uname.'@'.$udom; }      if ($name !~ /\S/) { $name=$uname.':'.$udom; }
     return $name;      return $name;
 }  }
   
Line 2168  category Line 2187  category
 =cut  =cut
   
 sub filecategorytypes {  sub filecategorytypes {
     return @{$category_extensions{lc($_[0])}};      my ($cat) = @_;
       return @{$category_extensions{lc($cat)}};
 }  }
   
 =pod  =pod
Line 2183  sub fileembstyle { Line 2203  sub fileembstyle {
     return $fe{lc(shift(@_))};      return $fe{lc(shift(@_))};
 }  }
   
   sub filemimetype {
       return $fm{lc(shift(@_))};
   }
   
   
 sub filecategoryselect {  sub filecategoryselect {
     my ($name,$value)=@_;      my ($name,$value)=@_;
Line 2239  sub fileextensions { Line 2263  sub fileextensions {
   
 sub display_languages {  sub display_languages {
     my %languages=();      my %languages=();
     foreach (&preferred_languages()) {      foreach my $lang (&preferred_languages()) {
  $languages{$_}=1;   $languages{$lang}=1;
     }      }
     &get_unprocessed_cgi($ENV{'QUERY_STRING'},['displaylanguage']);      &get_unprocessed_cgi($ENV{'QUERY_STRING'},['displaylanguage']);
     if ($env{'form.displaylanguage'}) {      if ($env{'form.displaylanguage'}) {
  foreach (split(/\s*(\,|\;|\:)\s*/,$env{'form.displaylanguage'})) {   foreach my $lang (split(/\s*(\,|\;|\:)\s*/,$env{'form.displaylanguage'})) {
     $languages{$_}=1;      $languages{$lang}=1;
         }          }
     }      }
     return %languages;      return %languages;
Line 2280  sub preferred_languages { Line 2304  sub preferred_languages {
     }      }
 # turn "en-ca" into "en-ca,en"  # turn "en-ca" into "en-ca,en"
     my @genlanguages;      my @genlanguages;
     foreach (@languages) {      foreach my $lang (@languages) {
  unless ($_=~/\w/) { next; }   unless ($lang=~/\w/) { next; }
  push (@genlanguages,$_);   push (@genlanguages,$lang);
  if ($_=~/(\-|\_)/) {   if ($lang=~/(\-|\_)/) {
     push (@genlanguages,(split(/(\-|\_)/,$_))[0]);      push(@genlanguages,(split(/(\-|\_)/,$lang))[0]);
  }   }
     }      }
     return @genlanguages;      return @genlanguages;
Line 2340  sub get_previous_attempt { Line 2364  sub get_previous_attempt {
       my %lasthash=();        my %lasthash=();
       my $version;        my $version;
       for ($version=1;$version<=$returnhash{'version'};$version++) {        for ($version=1;$version<=$returnhash{'version'};$version++) {
         foreach (sort(split(/\:/,$returnhash{$version.':keys'}))) {          foreach my $key (sort(split(/\:/,$returnhash{$version.':keys'}))) {
   $lasthash{$_}=$returnhash{$version.':'.$_};    $lasthash{$key}=$returnhash{$version.':'.$key};
         }          }
       }        }
       $prevattempts='<table border="0" width="100%"><tr><td bgcolor="#777777">';        $prevattempts='<table border="0" width="100%"><tr><td bgcolor="#777777">';
       $prevattempts.='<table border="0" width="100%"><tr bgcolor="#e6ffff"><td>History</td>';        $prevattempts.='<table border="0" width="100%"><tr bgcolor="#e6ffff"><td>History</td>';
       foreach (sort(keys %lasthash)) {        foreach my $key (sort(keys(%lasthash))) {
  my ($ign,@parts) = split(/\./,$_);   my ($ign,@parts) = split(/\./,$key);
  if ($#parts > 0) {   if ($#parts > 0) {
   my $data=$parts[-1];    my $data=$parts[-1];
   pop(@parts);    pop(@parts);
Line 2363  sub get_previous_attempt { Line 2387  sub get_previous_attempt {
       if ($getattempt eq '') {        if ($getattempt eq '') {
  for ($version=1;$version<=$returnhash{'version'};$version++) {   for ($version=1;$version<=$returnhash{'version'};$version++) {
   $prevattempts.='</tr><tr bgcolor="#ffffe6"><td>Transaction '.$version.'</td>';    $prevattempts.='</tr><tr bgcolor="#ffffe6"><td>Transaction '.$version.'</td>';
     foreach (sort(keys %lasthash)) {      foreach my $key (sort(keys(%lasthash))) {
        my $value;         my $value;
        if ($_ =~ /timestamp/) {         if ($key =~ /timestamp/) {
   $value=scalar(localtime($returnhash{$version.':'.$_}));    $value=scalar(localtime($returnhash{$version.':'.$key}));
        } else {         } else {
   $value=$returnhash{$version.':'.$_};    $value=$returnhash{$version.':'.$key};
        }         }
        $prevattempts.='<td>'.&Apache::lonnet::unescape($value).'&nbsp;</td>';            $prevattempts.='<td>'.&Apache::lonnet::unescape($value).'&nbsp;</td>';   
     }      }
  }   }
       }        }
       $prevattempts.='</tr><tr bgcolor="#ffffe6"><td>Current</td>';        $prevattempts.='</tr><tr bgcolor="#ffffe6"><td>Current</td>';
       foreach (sort(keys %lasthash)) {        foreach my $key (sort(keys(%lasthash))) {
  my $value;   my $value;
  if ($_ =~ /timestamp/) {   if ($key =~ /timestamp/) {
   $value=scalar(localtime($lasthash{$_}));    $value=scalar(localtime($lasthash{$key}));
  } else {   } else {
   $value=$lasthash{$_};    $value=$lasthash{$key};
  }   }
  $value=&Apache::lonnet::unescape($value);   $value=&Apache::lonnet::unescape($value);
  if ($_ =~/$regexp$/ && (defined &$gradesub)) {$value = &$gradesub($value)}   if ($key =~/$regexp$/ && (defined &$gradesub)) {$value = &$gradesub($value)}
  $prevattempts.='<td>'.$value.'&nbsp;</td>';   $prevattempts.='<td>'.$value.'&nbsp;</td>';
       }        }
       $prevattempts.='</tr></table></td></tr></table>';        $prevattempts.='</tr></table></td></tr></table>';
Line 2415  sub relative_to_absolute { Line 2439  sub relative_to_absolute {
  }   }
     }      }
     $thisdir=~s-/[^/]*$--;      $thisdir=~s-/[^/]*$--;
     foreach (@rlinks) {      foreach my $link (@rlinks) {
  unless (($_=~/^http:\/\//i) ||   unless (($link=~/^http:\/\//i) ||
  ($_=~/^\//) ||   ($link=~/^\//) ||
  ($_=~/^javascript:/i) ||   ($link=~/^javascript:/i) ||
  ($_=~/^mailto:/i) ||   ($link=~/^mailto:/i) ||
  ($_=~/^\#/)) {   ($link=~/^\#/)) {
     my $newlocation=&Apache::lonnet::hreflocation($thisdir,$_);      my $newlocation=&Apache::lonnet::hreflocation($thisdir,$link);
     $output=~s/(\"|\'|\=\s*)$_(\"|\'|\s|\>)/$1$newlocation$2/;      $output=~s/(\"|\'|\=\s*)\Q$link\E(\"|\'|\s|\>)/$1$newlocation$2/;
  }   }
     }      }
 # -------------------------------------------------- Deal with Applet codebases  # -------------------------------------------------- Deal with Applet codebases
Line 2590  sub maketime { Line 2614  sub maketime {
 #########################################  #########################################
   
 sub findallcourses {  sub findallcourses {
     my %courses=();      my ($roles) = @_;
       my %roles;
       if (ref($roles)) { %roles = map { $_ => 1 } @{$roles}; }
       my %courses;
     my $now=time;      my $now=time;
     foreach (keys %env) {      foreach my $key (keys(%env)) {
  if ($_=~/^user\.role\.\w+\.\/(\w+)\/(\w+)/) {   if ( $key=~m{^user\.role\.(\w+)\./(\w+)/(\w+)} ) {
     my ($starttime,$endtime)=$env{$_};      my ($role,$domain,$id) = ($1,$2,$3);
       next if ($role eq 'ca' || $role eq 'aa');
       next if (%roles && !exists($roles{$role}));
       my ($starttime,$endtime)=split(/\./,$env{$key});
             my $active=1;              my $active=1;
             if ($starttime) {              if ($starttime) {
  if ($now<$starttime) { $active=0; }   if ($now<$starttime) { $active=0; }
Line 2602  sub findallcourses { Line 2632  sub findallcourses {
             if ($endtime) {              if ($endtime) {
                 if ($now>$endtime) { $active=0; }                  if ($now>$endtime) { $active=0; }
             }              }
             if ($active) { $courses{$1.'_'.$2}=1; }              if ($active) { $courses{$domain.'_'.$id}=1; }
         }          }
     }      }
     return keys %courses;      return keys(%courses);
 }  }
   
 ###############################################  ###############################################
Line 2732  Inputs: Line 2762  Inputs:
 =item * $forcereg, if page should register as content page (relevant for   =item * $forcereg, if page should register as content page (relevant for 
             text interface only)              text interface only)
   
   =item * $customtitle, alternate text to use instead of $title
                         in the title box that appears, this text
                         is not auto translated like the $title is
   
   =item * $notopbar, if true, keep the 'what is this' info but remove the
                      navigational links
   
   =item * $bgcolor, used to override the bgcolor on a webpage to a specific value
   
   =item * $notitle, if true keep the nav controls, but remove the title bar
   
   
 =back  =back
   
 Returns: A uniform header for LON-CAPA web pages.    Returns: A uniform header for LON-CAPA web pages.  
Line 2742  other decorations will be returned. Line 2784  other decorations will be returned.
 =cut  =cut
   
 sub bodytag {  sub bodytag {
     my ($title,$function,$addentries,$bodyonly,$domain,$forcereg,$customtitle,$notopbar)=@_;      my ($title,$function,$addentries,$bodyonly,$domain,$forcereg,$customtitle,
    $notopbar,$bgcolor,$notitle)=@_;
   
     $title=&mt($title);      $title=&mt($title);
   
     $function = &get_users_function() if (!$function);      $function = &get_users_function() if (!$function);
     my $img=&designparm($function.'.img',$domain);      my $img =    &designparm($function.'.img',$domain);
     my $pgbg=&designparm($function.'.pgbg',$domain);      my $tabbg =  &designparm($function.'.tabbg',$domain);
     my $tabbg=&designparm($function.'.tabbg',$domain);      my $font =   &designparm($function.'.font',$domain);
     my $font=&designparm($function.'.font',$domain);      my $sidebg = &designparm($function.'.sidebg',$domain);
     my $link=&designparm($function.'.link',$domain);      my $pgbg   = $bgcolor || &designparm($function.'.pgbg',$domain);
     my $alink=&designparm($function.'.alink',$domain);  
     my $vlink=&designparm($function.'.vlink',$domain);      my %design = ( 'style'   => 'margin-top: 0px',
     my $sidebg=&designparm($function.'.sidebg',$domain);     'bgcolor' => $pgbg,
 # Accessibility font enhance     'text'    => $font,
     unless ($addentries) { $addentries=''; }                     'alink'   => &designparm($function.'.alink',$domain),
     my $addstyle='';     'vlink'   => &designparm($function.'.vlink',$domain),
     if ($env{'browser.fontenhance'} eq 'on') {     'link'    => &designparm($function.'.link',$domain),);
  $addstyle=' font-size: x-large;';      @$addentries{keys(%design)} = @design{keys(%design)};
     }  
  # role and realm   # role and realm
     my ($role,$realm)      my ($role,$realm)
        =&Apache::lonnet::plaintext((split(/\./,$env{'request.role'}))[0]);         =&Apache::lonnet::plaintext((split(/\./,$env{'request.role'}))[0]);
Line 2773  sub bodytag { Line 2818  sub bodytag {
 # Port for miniserver  # Port for miniserver
     my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'};      my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'};
     if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; }      if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; }
   
       my $extra_body_attr = &make_attr_string($forcereg,$addentries);
   
 # construct main body tag  # construct main body tag
     my $bodytag = <<END;      my $bodytag = <<END;
 <style type="text/css">  <body $extra_body_attr>
 h1, h2, h3, th { font-family: Arial, Helvetica, sans-serif }  
 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; }  
 </style>  
 <body bgcolor="$pgbg" text="$font" alink="$alink" vlink="$vlink" link="$link"  
 style="margin-top: 0px;$addstyle" $addentries>  
 END  END
     &Apache::lontexconvert::jsMath_reset();  
     if ($env{'environment.texengine'} eq 'jsMath') {      $bodytag .= &Apache::lontexconvert::init_math_support();
  $bodytag.=&Apache::lontexconvert::jsMath_header();  
     }  
   
     my $upperleft='<img src="http://'.$ENV{'HTTP_HOST'}.':'.      my $upperleft='<img src="http://'.$ENV{'HTTP_HOST'}.':'.
                    $lonhttpdPort.$img.'" alt="'.$function.'" />';                     $lonhttpdPort.$img.'" alt="'.$function.'" />';
     if ($bodyonly) {      if ($bodyonly 
    || ($env{'request.state'} eq 'construct' 
       && $env{'environment.remote'} ne 'off' )) {
         return $bodytag;          return $bodytag;
     } elsif ($env{'browser.interface'} eq 'textual') {      } elsif ($env{'browser.interface'} eq 'textual') {
 # Accessibility  # Accessibility
                       
         return $bodytag.&Apache::lonmenu::menubuttons($forcereg,'web',   $bodytag.=&Apache::lonmenu::menubuttons($forcereg,$forcereg);
                                                       $forcereg).   if (!$notitle) {
                '<h1>LON-CAPA: '.$title.'</h1>';      $bodytag.='<h1>LON-CAPA: '.$title.'</h1>';
    }
    return $bodytag;
     } elsif ($env{'environment.remote'} eq 'off') {      } elsif ($env{'environment.remote'} eq 'off') {
 # No Remote  # No Remote
  my $roleinfo=(<<ENDROLE);   my $roleinfo=(<<ENDROLE);
Line 2849  ENDROLE Line 2890  ENDROLE
             }              }
     $forcereg=1;      $forcereg=1;
         }          }
         my $titletable = '<table bgcolor="'.$pgbg.'" width="100%" border="0" '.          my $titletable;
    if (!$notitle) {
       $titletable =
    '<table bgcolor="'.$pgbg.'" width="100%" border="0" '.
                          'cellspacing="3" cellpadding="3">'.                           'cellspacing="3" cellpadding="3">'.
                          '<tr><td bgcolor="'.$tabbg.'">'.                           '<tr><td bgcolor="'.$tabbg.'">'.
                          $titleinfo.'</td>'.$roleinfo.'</tr></table>';                           $titleinfo.'</td>'.$roleinfo.'</tr></table>';
         if ($env{'request.state'} eq 'construct') {   }
    if ($env{'request.state'} eq 'construct') {
             if ($notopbar) {              if ($notopbar) {
                 $bodytag .= $titletable;                  $bodytag .= $titletable;
             } else {              } else {
                 $bodytag .= &Apache::lonmenu::menubuttons($forcereg,'web',$forcereg,$titletable);                  $bodytag .= &Apache::lonmenu::menubuttons($forcereg,$forcereg,
     $titletable);
             }              }
  } else {   } else {
             if ($notopbar) {              if ($notopbar) {
                 $bodytag .= $titletable;                  $bodytag .= $titletable;
             } else {              } else {
                 $bodytag .= &Apache::lonmenu::menubuttons($forcereg,'web',$forcereg).                  $bodytag .= &Apache::lonmenu::menubuttons($forcereg,$forcereg).
                         $titletable;                          $titletable;
             }              }
         }          }
Line 2887  ENDROLE Line 2933  ENDROLE
         $dc_info.= $cid.' '.$env{'course.'.$cid.'.internal.coursecode'};          $dc_info.= $cid.' '.$env{'course.'.$cid.'.internal.coursecode'};
         $dc_info = '('.$dc_info.')';          $dc_info = '('.$dc_info.')';
     }      }
       # Explicit link to get inline menu
       my $menu='<br /><font size="2" face="Arial, Helvetica, sans-serif">&nbsp;<a href="/adm/remote?action=collapse">'.&mt('Switch to Inline Menu Mode').'</a></font>';
     #      #
       if ($notitle) {
    return $bodytag;
       }
     return(<<ENDBODY);      return(<<ENDBODY);
 $bodytag  $bodytag
 <table width="100%" cellspacing="0" border="0" cellpadding="0">  <table width="100%" cellspacing="0" border="0" cellpadding="0">
Line 2897  $upperleft</td> Line 2948  $upperleft</td>
 </tr>  </tr>
 <tr>  <tr>
 <td rowspan="3" bgcolor="$tabbg">  <td rowspan="3" bgcolor="$tabbg">
 $titleinfo $dc_info  $titleinfo $dc_info $menu
 </td><td bgcolor="$tabbg" align="right">  </td><td bgcolor="$tabbg" align="right">
 <font size="2" face="Arial, Helvetica, sans-serif">  <font size="2" face="Arial, Helvetica, sans-serif">
     $env{'environment.firstname'}      $env{'environment.firstname'}
Line 2912  $titleinfo $dc_info Line 2963  $titleinfo $dc_info
 </td></tr>  </td></tr>
 <tr>  <tr>
 <td bgcolor="$tabbg" align="right"><font size="2" face="Arial, Helvetica, sans-serif">$realm</font>&nbsp;</td></tr>  <td bgcolor="$tabbg" align="right"><font size="2" face="Arial, Helvetica, sans-serif">$realm</font>&nbsp;</td></tr>
 </table><br />  </table>
 ENDBODY  ENDBODY
 }  }
   
   sub make_attr_string {
       my ($register,$attr_ref) = @_;
   
       if ($attr_ref && !ref($attr_ref)) {
    die("addentries Must be a hash ref ".
       join(':',caller(1))." ".
       join(':',caller(0))." ");
       }
   
       if ($register) {
    my ($on_load,$on_unload);
    foreach my $key (keys(%{$attr_ref})) {
       if      (lc($key) eq 'onload') {
    $on_load.=$attr_ref->{$key}.';';
    delete($attr_ref->{$key});
   
       } elsif (lc($key) eq 'onunload') {
    $on_unload.=$attr_ref->{$key}.';';
    delete($attr_ref->{$key});
       }
    }
    $attr_ref->{'onload'}  =
       &Apache::lonmenu::loadevents().  $on_load;
    $attr_ref->{'onunload'}=
       &Apache::lonmenu::unloadevents().$on_unload;
       }
   
   # Accessibility font enhance
       if ($env{'browser.fontenhance'} eq 'on') {
    my $style;
    foreach my $key (keys(%{$attr_ref})) {
       if (lc($key) eq 'style') {
    $style.=$attr_ref->{$key}.';';
    delete($attr_ref->{$key});
       }
    }
    $attr_ref->{'style'}=$style.'; font-size: x-large;';
       }
   
       if ($env{'browser.blackwhite'} eq 'on') {
    delete($attr_ref->{'font'});
    delete($attr_ref->{'link'});
    delete($attr_ref->{'alink'});
    delete($attr_ref->{'vlink'});
    delete($attr_ref->{'bgcolor'});
    delete($attr_ref->{'background'});
       }
   
       my $attr_string;
       foreach my $attr (keys(%$attr_ref)) {
    $attr_string .= " $attr=\"".$attr_ref->{$attr}.'" ';
       }
       return $attr_string;
   }
   
   
 ###############################################  ###############################################
 ###############################################  ###############################################
   
Line 2923  ENDBODY Line 3030  ENDBODY
   
 =back  =back
   
 =head1 HTTP Helpers  =head1 HTML Helpers
   
 =over 4  =over 4
   
Line 2931  ENDBODY Line 3038  ENDBODY
   
 Returns a uniform footer for LON-CAPA web pages.  Returns a uniform footer for LON-CAPA web pages.
   
 Inputs:   Inputs: none
   
 =over 4  
   
 =back  =back
   
 Returns: A uniform footer for LON-CAPA web pages.    
   
 =cut  =cut
   
 sub endbodytag {  sub endbodytag {
     my $endbodytag='</body>';      my $endbodytag='</body>';
     $endbodytag=&Apache::lontexconvert::jsMath_process()."\n".$endbodytag;      $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;      return $endbodytag;
 }  }
   
   =pod
   
   =over 4
   
   =item * &standard_css()
   
   Returns a style sheet
   
   Inputs: (all optional)
               domain         -> force to color decorate a page for a specific
                                  domain
               function       -> force usage of a specific rolish color scheme
               bgcolor        -> override the default page bgcolor
   
   =back
   
   =cut
   
   sub standard_css {
       my ($function,$domain,$bgcolor) = @_;
       $function  = &get_users_function() if (!$function);
       my $img    = &designparm($function.'.img',   $domain);
       my $tabbg  = &designparm($function.'.tabbg', $domain);
       my $font   = &designparm($function.'.font',  $domain);
       my $sidebg = &designparm($function.'.sidebg',$domain);
       my $pgbg   = $bgcolor ||
            &designparm($function.'.pgbg',  $domain);
       my $alink  = &designparm($function.'.alink', $domain);
       my $vlink  = &designparm($function.'.vlink', $domain);
       my $link   = &designparm($function.'.link',  $domain);
   
       my $sans                 = 'Arial,Helvetica,sans-serif';
       my $data_table_head      = $tabbg;
       my $data_table_light     = '#EEEEEE';
       my $data_table_dark      = '#DDD';
       my $data_table_highlight = '#FFFF00';
       my $mail_new             = '#FFBB77';
       my $mail_new_hover       = '#DD9955';
       my $mail_read            = '#BBBB77';
       my $mail_read_hover      = '#999944';
       my $mail_replied         = '#AAAA88';
       my $mail_replied_hover   = '#888855';
       my $mail_other           = '#99BBBB';
       my $mail_other_hover     = '#669999';
   
       return <<END;
   <style type="text/css">
   h1, h2, h3, th { font-family: $sans }
   a:focus { color: red; background: yellow } 
   table.thinborder { border-collapse: collapse; }
   table.thinborder tr th, table.thinborder tr td { border-style: solid; border-width: 1px}
   form, .inline { display: inline; }
   .center { text-align: center; }
   .filename {font-family: monospace;}
   .LC_error {
     color: red;
     font-size: larger;
   }
   .LC_success {
     color: green;
   }
   
   table#LC_top_nav, table#LC_menubuttons, table#LC_nav_location {
     width: 100%;
     background: $pgbg;
     border: 0px;
     border-spacing: 1px;
     padding: 0px;
     margin: 0px;
     border-collapse: separate;
   }
   table#LC_menubuttons_mainmenu {
     background: $pgbg;
     border: 0px;
     border-spacing: 1px;
     padding: 0px;
     margin: 0px;
     border-collapse: separate;
   }
   table#LC_menubuttons img, table#LC_menubuttons_mainmenu img {
     border: 0px;
   }
   table#LC_top_nav td {
     background: $tabbg;
   }
   table#LC_top_nav td a, div#LC_top_nav a {
     color: $font;
     font-family: $sans;
   }
   .LC_menubuttons_inline_text {
     color: $font;
     font-family: $sans;
     font-size: smaller;
   }
   
   td.LC_menubuttons_text {
     color: $font;
     font-family: $sans;
   }
   td.LC_menubuttons_img {
     background: $tabbg;
   }
   .LC_current_location {
     font-family: $sans;
     background: $tabbg;
   }
   .LC_new_mail {
     font-family: $sans;
     font-weight: bold;
   }
   
   table.LC_data_table, table.LC_mail_list {
     border: 1px solid #000000;
     border-collapse: seperate;
   }
   table.LC_data_table tr th, table.LC_calendar tr th, table.LC_mail_list tr th {
     font-weight: bold;
     background-color: $data_table_head;
   }
   table.LC_data_table tr td {
     background-color: $data_table_light;
   }
   table.LC_data_table tr.LC_even_row td {
     background-color: $data_table_dark;
   }
   table.LC_data_table tr.LC_empty td {
     background-color: #FFFFFF;
   }
   
   table.LC_calendar {
     border: 1px solid #000000;
     border-collapse: collapse;
   }
   table.LC_calendar_pickdate {
     font-size: xx-small;
   }
   table.LC_calendar tr td {
     border: 1px solid #000000;
     vertical-align: top;
   }
   table.LC_calendar tr td.LC_calendar_day_empty {
     background-color: $data_table_dark;
   }
   table.LC_calendar tr td.LC_calendar_day_current {
     background-color: $data_table_highlight;
   }
   
   table.LC_mail_list tr.LC_mail_new {
     background-color: $mail_new;
   }
   table.LC_mail_list tr.LC_mail_new:hover {
     background-color: $mail_new_hover;
   }
   table.LC_mail_list tr.LC_mail_read {
     background-color: $mail_read;
   }
   table.LC_mail_list tr.LC_mail_read:hover {
     background-color: $mail_read_hover;
   }
   table.LC_mail_list tr.LC_mail_replied {
     background-color: $mail_replied;
   }
   table.LC_mail_list tr.LC_mail_replied:hover {
     background-color: $mail_replied_hover;
   }
   table.LC_mail_list tr.LC_mail_other {
     background-color: $mail_other;
   }
   table.LC_mail_list tr.LC_mail_other:hover {
     background-color: $mail_other_hover;
   }
   </style>
   END
   }
   
   =pod
   
   =over 4
   
   =item * &headtag()
   
   Returns a uniform footer for LON-CAPA web pages.
   
   Inputs: $title - optional title for the head
           $head_extra - optional extra HTML to put inside the <head>
           $args - optional arguments
               force_register - if is true call registerurl so the remote is 
                                informed
               redirect       -> array ref of seconds before redirect occurs
                                       url to redirect to
                              (side effect of setting 
                                  $env{'internal.head.redirect'} to the url 
                                  redirected too)
               domain         -> force to color decorate a page for a specific
                                  domain
               function       -> force usage of a specific rolish color scheme
               bgcolor        -> override the default page bgcolor
   
   =back
   
   =cut
   
   sub headtag {
       my ($title,$head_extra,$args) = @_;
       
       my $result =
    '<head>'.
    &standard_css($args->{'function'},$args->{'domain'},
         $args->{'bgcolor'}).
    &font_settings().
    &Apache::lonhtmlcommon::htmlareaheaders();
   
       if ($args->{'force_register'}) {
    $result .= &Apache::lonmenu::registerurl(1);
       }
   
       if (ref($args->{'redirect'})) {
    my ($time,$url) = @{$args->{'redirect'}};
    $url = &Apache::lonenc::check_encrypt($url);
    $env{'internal.head.redirect'} = $url;
    $result.=<<ADDMETA
   <meta http-equiv="pragma" content="no-cache" />
   <meta http-equiv="Refresh" content="$time; url=$url" />
   ADDMETA
       }
       if (!defined($title)) {
    $title = 'The LearningOnline Network with CAPA';
       }
       
       $result .= '<title> LON-CAPA '.&mt($title).'</title>'.$head_extra;
       return $result;
   }
   
   =pod
   
   =over 4
   
   =item * &font_settings()
   
   Returns neccessary <meta> to set the proper encoding
   
   Inputs: none
   
   =back
   
   =cut
   
   sub font_settings {
       my $headerstring='';
       if (($env{'browser.os'} eq 'mac') && (!$env{'browser.mathml'})) { 
    $headerstring.=
       '<meta Content-Type="text/html; charset=x-mac-roman" />';
       } elsif (!$env{'browser.mathml'} && $env{'browser.unicode'}) {
    $headerstring.=
       '<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />';
       }
       return $headerstring;
   }
   
   =pod
   
   =over 4
   
   =item * &xml_begin()
   
   Returns the needed doctype and <html>
   
   Inputs: none
   
   =back
   
   =cut
   
   sub xml_begin {
       my $output='';
   
       &Apache::lonhtmlcommon::init_htmlareafields();
   
       if ($env{'browser.mathml'}) {
    $output='<?xml version="1.0"?>'
               #.'<?xml-stylesheet type="text/css" href="/adm/MathML/mathml.css"?>'."\n"
   #            .'<!DOCTYPE html SYSTEM "/adm/MathML/mathml.dtd" '
               
   #    .'<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd" [<!ENTITY mathns "http://www.w3.org/1998/Math/MathML">] >'
       .'<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1 plus MathML 2.0 plus SVG 1.1//EN" "http://www.w3.org/2002/04/xhtml-math-svg/xhtml-math-svg.dtd">'
               .'<html xmlns:math="http://www.w3.org/1998/Math/MathML" ' 
       .'xmlns="http://www.w3.org/1999/xhtml">';
       } else {
    $output='<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"><html>';
       }
       return $output;
   }
   
   =pod
   
   =over 4
   
   =item * &endheadtag()
   
   Returns a uniform </head> for LON-CAPA web pages.
   
   Inputs: none
   
   =back
   
   =cut
   
   sub endheadtag {
       return '</head>';
   }
   
   =pod
   
   =over 4
   
   =item * &head()
   
   Returns a uniform complete <head>..</head> section for LON-CAPA web pages.
   
   Inputs: $title - optional title for the page
           $head_extra - optional extra HTML to put inside the <head>
   =back
   
   =cut
   
   sub head {
       my ($title,$head_extra,$args) = @_;
       return &headtag($title,$head_extra,$args).&endheadtag();
   }
   
   =pod
   
   =over 4
   
   =item * &start_page()
   
   Returns a complete <html> .. <body> section for LON-CAPA web pages.
   
   Inputs: $title - optional title for the page
           $head_extra - optional extra HTML to incude inside the <head>
           $args - additional optional args supported are:
                     only_body      -> is true will set &bodytag() onlybodytag
                                       arg on
                     no_nav_bar     -> is true will set &bodytag() notopbar arg on
                     add_entries    -> additional attributes to add to the  <body>
                     domain         -> force to color decorate a page for a 
                                       specific domain
                     function       -> force usage of a specific rolish color
                                       scheme
                     redirect       -> see &headtag()
                     bgcolor        -> override the default page bg color
                     js_ready       -> return a string ready for being used in 
                                       a javascript writeln
                     html_encode    -> return a string ready for being used in 
                                       a html attribute
                     force_register -> if is true will turn on the &bodytag()
                                       $forcereg arg
                     body_title     -> alternate text to use instead of $title
                                       in the title box that appears, this text
                                       is not auto translated like the $title is
                     frameset       -> if true will start with a <frameset>
                                       rather than <body>
                     no_title       -> if true the title bar won't be shown
                     skip_phases    -> hash ref of 
                                       head -> skip the <html><head> generation
                                       body -> skip all <body> generation
   
   =back
   
   =cut
   
   sub start_page {
       my ($title,$head_extra,$args) = @_;
       #&Apache::lonnet::logthis("start_page ".join(':',caller(0)));
       my %head_args;
       foreach my $arg ('redirect','force_register','domain','function',
        'bgcolor') {
    if (defined($args->{$arg})) {
       $head_args{$arg} = $args->{$arg};
    }
       }
   
       $env{'internal.start_page'}++;
       my $result;
       if (! exists($args->{'skip_phases'}{'head'}) ) {
    $result.=
       &xml_begin().
       &headtag($title,$head_extra,\%head_args).&endheadtag();
       }
       
       if (! exists($args->{'skip_phases'}{'body'}) ) {
    if ($args->{'frameset'}) {
       my $attr_string = &make_attr_string($args->{'force_register'},
    $args->{'add_entries'});
       $result .= "\n<frameset $attr_string>\n";
    } else {
       $result .=
    &bodytag($title, 
    $args->{'function'},       $args->{'add_entries'},
    $args->{'only_body'},      $args->{'domain'},
    $args->{'force_register'}, $args->{'body_title'},
    $args->{'no_nav_bar'},     $args->{'bgcolor'},
    $args->{'no_title'});
    }
       }
   
       if ($args->{'js_ready'}) {
    $result = &js_ready($result);
       }
       if ($args->{'html_encode'}) {
    $result = &html_encode($result);
       }
       return $result;
   }
   
   
   =pod
   
   =over 4
   
   =item * &head()
   
   Returns a complete </body></html> section for LON-CAPA web pages.
   
   Inputs:         $args - additional optional args supported are:
                    js_ready     -> return a string ready for being used in 
                                    a javascript writeln
                    html_encode  -> return a string ready for being used in 
                                    a html attribute
                    frameset     -> if true will start with a <frameset>
                                    rather than <body>
   =back
   
   =cut
   
   sub end_page {
       my ($args) = @_;
       #&Apache::lonnet::logthis("end_page ".join(':',caller(0)));
       $env{'internal.end_page'}++;
       my $result;
       if ($args->{'discussion'}) {
    my ($target,$parser);
    if (ref($args->{'discussion'})) {
       ($target,$parser) =($args->{'discussion'}{'target'},
    $args->{'discussion'}{'parser'});
    }
    $result .= &Apache::lonxml::xmlend($target,$parser);
       }
   
       if ($args->{'frameset'}) {
    $result .= '</frameset>';
       } else {
    $result .= &endbodytag();
       }
       $result .= "\n</html>";
   
       if ($args->{'js_ready'}) {
    $result = &js_ready($result);
       }
   
       if ($args->{'html_encode'}) {
    $result = &html_encode($result);
       }
   
       return $result;
   }
   
   sub html_encode {
       my ($result) = @_;
   
       $result = &HTML::Entities::encode($result,'<>&"');
       
       return $result;
   }
   sub js_ready {
       my ($result) = @_;
   
       $result =~ s/[\n\r]/ /xmsg;
       $result =~ s/\\/\\\\/xmsg;
       $result =~ s/'/\\'/xmsg;
       $result =~ s{</script>}{</scrip'+'t>}xmsg;
       
       return $result;
   }
   
   sub validate_page {
       if (  exists($env{'internal.start_page'})
     &&     $env{'internal.start_page'} > 1) {
    &Apache::lonnet::logthis('start_page called multiple times '.
    $env{'internal.start_page'}.' '.
    $ENV{'request.filename'});
       }
       if (  exists($env{'internal.end_page'})
     &&     $env{'internal.end_page'} > 1) {
    &Apache::lonnet::logthis('end_page called multiple times '.
    $env{'internal.end_page'}.' '.
    $env{'request.filename'});
       }
       if (     exists($env{'internal.start_page'})
    && ! exists($env{'internal.end_page'})) {
    &Apache::lonnet::logthis('start_page called without end_page '.
    $env{'request.filename'});
       }
       if (   ! exists($env{'internal.start_page'})
    &&   exists($env{'internal.end_page'})) {
    &Apache::lonnet::logthis('end_page called without start_page'.
    $env{'request.filename'});
       }
   }
   
   sub simple_error_page {
       my ($r,$title,$msg) = @_;
       my $page =
    &Apache::loncommon::start_page($title).
    &mt($msg).
    &Apache::loncommon::end_page();
       if (ref($r)) {
    $r->print($page);
    return;
       }
       return $page;
   }
   
   {
       my $row_count;
       sub start_data_table {
    undef($row_count);
    return '<table class="LC_data_table">';
       }
   
       sub end_data_table {
    undef($row_count);
    return '</table>';
       }
   
       sub start_data_table_row {
    $row_count++;
    return  '<tr '.(($row_count % 2)?'':'class="LC_even_row"').'>';
       }
   
       sub end_data_table_row {
    return '</tr>';
       }
   }
   
 ###############################################  ###############################################
   
 =pod  =pod
   
   =over 4
   
 =item get_users_function  =item get_users_function
   
 Used by &bodytag to determine the current users primary role.  Used by &bodytag to determine the current users primary role.
Line 3165  times for group members. Line 3821  times for group members.
 Outer hash key is functions.  Outer hash key is functions.
 Inner hash keys are chat,discussion,email,files,homepage,roster.  Inner hash keys are chat,discussion,email,files,homepage,roster.
 Corresponding values are either on or off, depending on  Corresponding values are either on or off, depending on
 whther this type of functionality is available for the group.  whether this type of functionality is available for the group.
   
 =cut  =cut
                                                                                                                                                                     
Line 3176  sub get_group_settings { Line 3832  sub get_group_settings {
     my $parser=HTML::TokeParser->new(\$groupinfo);      my $parser=HTML::TokeParser->new(\$groupinfo);
     my $token;      my $token;
     my $tool = '';      my $tool = '';
       my $role = '';
     my %content=();      my %content=();
     while ($token=$parser->get_token) {      while ($token=$parser->get_token) {
         if ($token->[0] eq 'S')  {          if ($token->[0] eq 'S')  {
             my $entry=$token->[1];              my $entry=$token->[1];
             if ($entry eq 'functions') {              if ($entry eq 'functions' || $entry eq 'autosec') {
                 %{$content{$entry}} = ();                  %{$content{$entry}} = ();
                 $tool = $entry;                  $tool = $entry;
               } elsif ($entry eq 'role') {
                   if ($tool eq 'autosec') {
                       $role = $token->[2]{id};
                   }
             } else {              } else {
                 my $value=$parser->get_text('/'.$entry);                  my $value=$parser->get_text('/'.$entry);
                 if ($entry eq 'name') {                  if ($entry eq 'name') {
Line 3192  sub get_group_settings { Line 3853  sub get_group_settings {
                     }                      }
                 } elsif ($entry eq 'groupname') {                  } elsif ($entry eq 'groupname') {
                     $content{$entry}=&Apache::lonnet::unescape($value);                      $content{$entry}=&Apache::lonnet::unescape($value);
                   } elsif (($entry eq 'roles') || ($entry eq 'types') ||
                            ($entry eq 'sectionpick') || ($entry eq 'defpriv')) {
                       push(@{$content{$entry}},$value);
                   } elsif ($entry eq 'section') {
                       if ($tool eq 'autosec'  && $role ne '') {
                           push(@{$content{$tool}{$role}},$value);
                       }
                 } else {                  } else {
                     $content{$entry}=$value;                      $content{$entry}=$value;
                 }                  }
             }              }
         } elsif ($token->[0] eq 'E') {          } elsif ($token->[0] eq 'E') {
             if ($token->[1] eq 'functions') {              if ($token->[1] eq 'functions' || $token->[1] eq 'autosec') {
                 $tool = '';                  $tool = '';
               } elsif ($token->[1] eq 'role') {
                   $role = '';
             }              }
   
         }          }
     }      }
     return %content;      return %content;
Line 3348  sub get_user_info { Line 4019  sub get_user_info {
     return;      return;
 }  }
   
 ###############################################  
   
 sub get_posted_cgi {  
     my $r=shift;  
   
     my $buffer;  
     if ($r->header_in('Content-length')) {  
  $r->read($buffer,$r->header_in('Content-length'),0);  
     }  
     unless ($buffer=~/^(\-+\w+)\s+Content\-Disposition\:\s*form\-data/si) {  
  my @pairs=split(/&/,$buffer);  
  my $pair;  
  foreach $pair (@pairs) {  
     my ($name,$value) = split(/=/,$pair);  
     $value =~ tr/+/ /;  
     $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;  
     $name  =~ tr/+/ /;  
     $name  =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;  
     &add_to_env("form.$name",$value);  
  }  
     } else {  
  my $contentsep=$1;  
  my @lines = split (/\n/,$buffer);  
  my $name='';  
  my $value='';  
  my $fname='';  
  my $fmime='';  
  my $i;  
  for ($i=0;$i<=$#lines;$i++) {  
     if ($lines[$i]=~/^$contentsep/) {  
  if ($name) {  
     chomp($value);  
     if ($fname) {  
  $env{"form.$name.filename"}=$fname;  
  $env{"form.$name.mimetype"}=$fmime;  
     } else {  
  $value=~s/\s+$//s;  
     }  
     &add_to_env("form.$name",$value);  
  }  
  if ($i<$#lines) {  
     $i++;  
     $lines[$i]=~  
  /Content\-Disposition\:\s*form\-data\;\s*name\=\"([^\"]+)\"/i;  
     $name=$1;  
     $value='';  
     if ($lines[$i]=~/filename\=\"([^\"]+)\"/i) {  
  $fname=$1;  
  if   
                             ($lines[$i+1]=~/Content\-Type\:\s*([\w\-\/]+)/i) {  
  $fmime=$1;  
  $i++;  
     } else {  
  $fmime='';  
     }  
     } else {  
  $fname='';  
  $fmime='';  
     }  
     $i++;  
  }  
     } else {  
  $value.=$lines[$i]."\n";  
     }  
  }  
     }  
     $env{'request.method'}=$ENV{'REQUEST_METHOD'};  
     $r->method_number(M_GET);  
     $r->method('GET');  
     $r->headers_in->unset('Content-length');  
 }  
   
 =pod  =pod
   
 =item * get_unprocessed_cgi($query,$possible_names)  =item * get_unprocessed_cgi($query,$possible_names)
Line 3438  will result in $env{'form.uname'} and $e Line 4037  will result in $env{'form.uname'} and $e
 sub get_unprocessed_cgi {  sub get_unprocessed_cgi {
   my ($query,$possible_names)= @_;    my ($query,$possible_names)= @_;
   # $Apache::lonxml::debug=1;    # $Apache::lonxml::debug=1;
   foreach (split(/&/,$query)) {    foreach my $pair (split(/&/,$query)) {
     my ($name, $value) = split(/=/,$_);      my ($name, $value) = split(/=/,$pair);
     $name = &Apache::lonnet::unescape($name);      $name = &Apache::lonnet::unescape($name);
     if (!defined($possible_names) || (grep {$_ eq $name} @$possible_names)) {      if (!defined($possible_names) || (grep {$_ eq $name} @$possible_names)) {
       $value =~ tr/+/ /;        $value =~ tr/+/ /;
Line 3656  sub record_sep { Line 4255  sub record_sep {
     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{&takeleft($i)}=$field;              $components{&takeleft($i)}=$field;
Line 3665  sub record_sep { Line 4263  sub record_sep {
         }          }
     } 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{&takeleft($i)}=$field;              $components{&takeleft($i)}=$field;
Line 3724  sub upfile_select_html { Line 4321  sub upfile_select_html {
     return $Str;      return $Str;
 }  }
   
   sub get_samples {
       my ($records,$toget) = @_;
       my @samples=({});
       my $got=0;
       foreach my $rec (@$records) {
    my %temp = &record_sep($rec);
    if (! grep(/\S/, values(%temp))) { next; }
    if (%temp) {
       $samples[$got]=\%temp;
       $got++;
       if ($got == $toget) { last; }
    }
       }
       return \@samples;
   }
   
 ######################################################  ######################################################
 ######################################################  ######################################################
   
Line 3741  Apache Request ref, $records is an array Line 4354  Apache Request ref, $records is an array
 ######################################################  ######################################################
 sub csv_print_samples {  sub csv_print_samples {
     my ($r,$records) = @_;      my ($r,$records) = @_;
     my (%sone,%stwo,%sthree);      my $samples = &get_samples($records,3);
     %sone=&record_sep($$records[0]);  
     if (defined($$records[1])) {%stwo=&record_sep($$records[1]);}  
     if (defined($$records[2])) {%sthree=&record_sep($$records[2]);}  
     #  
     $r->print(&mt('Samples').'<br /><table border="2"><tr>');      $r->print(&mt('Samples').'<br /><table border="2"><tr>');
     foreach (sort({$a <=> $b} keys(%sone))) {       foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) { 
         $r->print('<th>'.&mt('Column&nbsp;[_1]',($_+1)).'</th>'); }          $r->print('<th>'.&mt('Column&nbsp;[_1]',($sample+1)).'</th>'); }
     $r->print('</tr>');      $r->print('</tr>');
     foreach my $hash (\%sone,\%stwo,\%sthree) {      foreach my $hash (@$samples) {
  $r->print('<tr>');   $r->print('<tr>');
  foreach (sort({$a <=> $b} keys(%sone))) {   foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
     $r->print('<td>');      $r->print('<td>');
     if (defined($$hash{$_})) { $r->print($$hash{$_}); }      if (defined($$hash{$sample})) { $r->print($$hash{$sample}); }
     $r->print('</td>');      $r->print('</td>');
  }   }
  $r->print('</tr>');   $r->print('</tr>');
Line 3781  $d is an array of 2 element arrays (inte Line 4391  $d is an array of 2 element arrays (inte
 ######################################################  ######################################################
 sub csv_print_select_table {  sub csv_print_select_table {
     my ($r,$records,$d) = @_;      my ($r,$records,$d) = @_;
     my $i=0;my %sone;      my $i=0;
     %sone=&record_sep($$records[0]);      my $samples = &get_samples($records,1);
     $r->print(&mt('Associate columns with student attributes.')."\n".      $r->print(&mt('Associate columns with student attributes.')."\n".
      '<table border="2"><tr>'.       '<table border="2"><tr>'.
               '<th>'.&mt('Attribute').'</th>'.                '<th>'.&mt('Attribute').'</th>'.
               '<th>'.&mt('Column').'</th></tr>'."\n");                '<th>'.&mt('Column').'</th></tr>'."\n");
     foreach (@$d) {      foreach my $array_ref (@$d) {
  my ($value,$display,$defaultcol)=@{ $_ };   my ($value,$display,$defaultcol)=@{ $array_ref };
  $r->print('<tr><td>'.$display.'</td>');   $r->print('<tr><td>'.$display.'</td>');
   
  $r->print('<td><select name=f'.$i.   $r->print('<td><select name=f'.$i.
   ' onchange="javascript:flip(this.form,'.$i.');">');    ' onchange="javascript:flip(this.form,'.$i.');">');
  $r->print('<option value="none"></option>');   $r->print('<option value="none"></option>');
  foreach (sort({$a <=> $b} keys(%sone))) {   foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
     $r->print('<option value="'.$_.'"'.      $r->print('<option value="'.$sample.'"'.
                       ($_ eq $defaultcol ? ' selected="selected" ' : '').                        ($sample eq $defaultcol ? ' selected="selected" ' : '').
                       '>Column '.($_+1).'</option>');                        '>Column '.($sample+1).'</option>');
  }   }
  $r->print('</select></td></tr>'."\n");   $r->print('</select></td></tr>'."\n");
  $i++;   $i++;
Line 3825  $d is an array of 2 element arrays (inte Line 4435  $d is an array of 2 element arrays (inte
 ######################################################  ######################################################
 sub csv_samples_select_table {  sub csv_samples_select_table {
     my ($r,$records,$d) = @_;      my ($r,$records,$d) = @_;
     my %sone; my %stwo; my %sthree;  
     my $i=0;      my $i=0;
     #      #
       my $samples = &get_samples($records,3);
     $r->print('<table border=2><tr><th>'.      $r->print('<table border=2><tr><th>'.
               &mt('Field').'</th><th>'.&mt('Samples').'</th></tr>');                &mt('Field').'</th><th>'.&mt('Samples').'</th></tr>');
     %sone=&record_sep($$records[0]);  
     if (defined($$records[1])) {%stwo=&record_sep($$records[1]);}      foreach my $key (sort(keys(%{ $samples->[0] }))) {
     if (defined($$records[2])) {%sthree=&record_sep($$records[2]);}  
     #  
     foreach (sort keys %sone) {  
  $r->print('<tr><td><select name="f'.$i.'"'.   $r->print('<tr><td><select name="f'.$i.'"'.
   ' onchange="javascript:flip(this.form,'.$i.');">');    ' onchange="javascript:flip(this.form,'.$i.');">');
  foreach (@$d) {   foreach my $option (@$d) {
     my ($value,$display,$defaultcol)=@{ $_ };      my ($value,$display,$defaultcol)=@{ $option };
     $r->print('<option value="'.$value.'"'.      $r->print('<option value="'.$value.'"'.
                       ($i eq $defaultcol ? ' selected="selected" ':'').'>'.                        ($i eq $defaultcol ? ' selected="selected" ':'').'>'.
                       $display.'</option>');                        $display.'</option>');
  }   }
  $r->print('</select></td><td>');   $r->print('</select></td><td>');
  if (defined($sone{$_})) { $r->print($sone{$_}."<br />\n"); }   foreach my $line (0..2) {
  if (defined($stwo{$_})) { $r->print($stwo{$_}."<br />\n"); }      if (defined($samples->[$line]{$key})) { 
  if (defined($sthree{$_})) { $r->print($sthree{$_}."<br />\n"); }   $r->print($samples->[$line]{$key}."<br />\n"); 
       }
    }
  $r->print('</td></tr>');   $r->print('</td></tr>');
  $i++;   $i++;
     }      }
Removed from v.1.300  
changed lines
  Added in v.1.356

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