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

Diff for /loncom/interface/loncommon.pm between versions 1.651 and 1.692.2.4

version 1.651, 2008/03/28 21:05:28 version 1.692.2.4, 2008/12/14 04:22:39
Line 61  use POSIX qw(strftime mktime); Line 61  use POSIX qw(strftime mktime);
 use Apache::lonmenu();  use Apache::lonmenu();
 use Apache::lonenc();  use Apache::lonenc();
 use Apache::lonlocal;  use Apache::lonlocal;
   use Apache::lonnet();
 use HTML::Entities;  use HTML::Entities;
 use Apache::lonhtmlcommon();  use Apache::lonhtmlcommon();
 use Apache::loncoursedata();  use Apache::loncoursedata();
 use Apache::lontexconvert();  use Apache::lontexconvert();
 use Apache::lonclonecourse();  use Apache::lonclonecourse();
 use LONCAPA qw(:DEFAULT :match);  use LONCAPA qw(:DEFAULT :match);
   use DateTime::TimeZone;
   use DateTime::Locale::Catalog;
   
 # ---------------------------------------------- Designs  # ---------------------------------------------- Designs
 use vars qw(%defaultdesign);  use vars qw(%defaultdesign);
Line 447  sub selectstudent_link { Line 450  sub selectstudent_link {
    return '';     return '';
 }  }
   
   sub authorbrowser_javascript {
       return <<"ENDAUTHORBRW";
   <script type="text/javascript">
   var stdeditbrowser;
   
   function openauthorbrowser(formname,udom) {
       var url = '/adm/pickauthor?';
       url += 'form='+formname+'&roledom='+udom;
       var title = 'Author_Browser';
       var options = 'scrollbars=1,resizable=1,menubar=0';
       options += ',width=700,height=600';
       stdeditbrowser = open(url,title,options,'1');
       stdeditbrowser.focus();
   }
   
   </script>
   ENDAUTHORBRW
   }
   
 sub coursebrowser_javascript {  sub coursebrowser_javascript {
     my ($domainfilter,$sec_element,$formname)=@_;      my ($domainfilter,$sec_element,$formname)=@_;
     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');      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');
Line 584  sub selectcourse_link { Line 606  sub selectcourse_link {
         '","'.$udomele.'","'.$desc.'","'.$extra_element.'","'.$multflag.'","'.$selecttype.'");'."'>".&mt('Select Course')."</a>";          '","'.$udomele.'","'.$desc.'","'.$extra_element.'","'.$multflag.'","'.$selecttype.'");'."'>".&mt('Select Course')."</a>";
 }  }
   
   sub selectauthor_link {
      my ($form,$udom)=@_;
      return '<a href="javascript:openauthorbrowser('."'$form','$udom'".');">'.
             &mt('Select Author').'</a>';
   }
   
 sub check_uncheck_jscript {  sub check_uncheck_jscript {
     my $jscript = <<"ENDSCRT";      my $jscript = <<"ENDSCRT";
 function checkAll(field) {  function checkAll(field) {
Line 609  ENDSCRT Line 637  ENDSCRT
     return $jscript;      return $jscript;
 }  }
   
   sub select_timezone {
      my ($name,$selected,$onchange,$includeempty)=@_;
      my $output='<select name="'.$name.'" '.$onchange.'>'."\n";
      if ($includeempty) {
          $output .= '<option value=""';
          if (($selected eq '') || ($selected eq 'local')) {
              $output .= ' selected="selected" ';
          }
          $output .= '> </option>';
      }
      my @timezones = DateTime::TimeZone->all_names;
      foreach my $tzone (@timezones) {
          $output.= '<option value="'.$tzone.'"';
          if ($tzone eq $selected) {
              $output.=' selected="selected"';
          }
          $output.=">$tzone</option>\n";
      }
      $output.="</select>";
      return $output;
   }
   
   sub select_datelocale {
       my ($name,$selected,$onchange,$includeempty)=@_;
       my $output='<select name="'.$name.'" '.$onchange.'>'."\n";
       if ($includeempty) {
           $output .= '<option value=""';
           if ($selected eq '') {
               $output .= ' selected="selected" ';
           }
           $output .= '> </option>';
       }
       my (@possibles,%locale_names);
       my @locales = DateTime::Locale::Catalog::Locales;
       foreach my $locale (@locales) {
           if (ref($locale) eq 'HASH') {
               my $id = $locale->{'id'};
               if ($id ne '') {
                   my $en_terr = $locale->{'en_territory'};
                   my $native_terr = $locale->{'native_territory'};
                   my @languages = &Apache::lonlocal::preferred_languages();
                   if (grep(/^en$/,@languages) || !@languages) {
                       if ($en_terr ne '') {
                           $locale_names{$id} = '('.$en_terr.')';
                       } elsif ($native_terr ne '') {
                           $locale_names{$id} = $native_terr;
                       }
                   } else {
                       if ($native_terr ne '') {
                           $locale_names{$id} = $native_terr.' ';
                       } elsif ($en_terr ne '') {
                           $locale_names{$id} = '('.$en_terr.')';
                       }
                   }
                   push (@possibles,$id);
               }
           }
       }
       foreach my $item (sort(@possibles)) {
           $output.= '<option value="'.$item.'"';
           if ($item eq $selected) {
               $output.=' selected="selected"';
           }
           $output.=">$item";
           if ($locale_names{$item} ne '') {
               $output.="  $locale_names{$item}</option>\n";
           }
           $output.="</option>\n";
       }
       $output.="</select>";
       return $output;
   }
   
 =pod  =pod
   
Line 826  sub help_open_topic { Line 926  sub help_open_topic {
     if ($text ne "") {      if ($text ne "") {
  $template .=    $template .= 
             "<table bgcolor='#3333AA' cellspacing='1' cellpadding='1' border='0'><tr>".              "<table bgcolor='#3333AA' cellspacing='1' cellpadding='1' border='0'><tr>".
             "<td bgcolor='#5555FF'><a target=\"_top\" href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";              "<td bgcolor='#5555FF'><span class=\"LC_nobreak\"><a target=\"_top\" href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";
     }      }
   
     # Add the graphic      # Add the graphic
     my $title = &mt('Online Help');      my $title = &mt('Online Help');
     my $helpicon=&lonhttpdurl("/res/adm/pages/help.png");      my $helpicon=&lonhttpdurl("/adm/help/help.png");
     $template .= <<"ENDTEMPLATE";      $template .= <<"ENDTEMPLATE";
  <a target="_top" href="$link" title="$title"><img src="$helpicon" border="0" alt="(Help: $topic)" /></a>   <a target="_top" 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.='</span></td></tr></table>' };
     return $template;      return $template;
   
 }  }
Line 857  sub helpLatexCheatsheet { Line 957  sub helpLatexCheatsheet {
  .'</td><td>'.   .'</td><td>'.
  &Apache::loncommon::help_open_topic("Other_Symbols",&mt('Other Symbols'),   &Apache::loncommon::help_open_topic("Other_Symbols",&mt('Other Symbols'),
     undef,undef,600)      undef,undef,600)
    .'</td><td>'.
    &Apache::loncommon::help_open_topic("Authoring_Output_Tags",&mt('Output Tags'),
                                       undef,undef,600)
  .'</td></tr></table>';   .'</td></tr></table>';
 }  }
   
Line 866  sub general_help { Line 969  sub general_help {
  $helptopic='Authoring_Intro';   $helptopic='Authoring_Intro';
     } elsif ($env{'request.role'}=~/^cc/) {      } elsif ($env{'request.role'}=~/^cc/) {
  $helptopic='Course_Coordination_Intro';   $helptopic='Course_Coordination_Intro';
       } elsif ($env{'request.role'}=~/^dc/) {
           $helptopic='Domain_Coordination_Intro';
     }      }
     return $helptopic;      return $helptopic;
 }  }
Line 1455  sub create_text_file { Line 1560  sub create_text_file {
     $fh = Apache::File->new('>/home/httpd'.$filename);      $fh = Apache::File->new('>/home/httpd'.$filename);
     if (! defined($fh)) {      if (! defined($fh)) {
         $r->log_error("Couldn't open $filename for output $!");          $r->log_error("Couldn't open $filename for output $!");
         $r->print("Problems occured in creating the output file.  ".          $r->print(&mt('Problems occurred in creating the output file. '
                   "This error has been logged.  ".                       .'This error has been logged. '
                   "Please alert your LON-CAPA administrator.");                       .'Please alert your LON-CAPA administrator.'));
     }      }
     return ($fh,$filename)      return ($fh,$filename)
 }  }
Line 2893  sub fileextensions { Line 2998  sub fileextensions {
   
 sub display_languages {  sub display_languages {
     my %languages=();      my %languages=();
     foreach my $lang (&preferred_languages()) {      foreach my $lang (&Apache::lonlocal::preferred_languages()) {
  $languages{$lang}=1;   $languages{$lang}=1;
     }      }
     &get_unprocessed_cgi($ENV{'QUERY_STRING'},['displaylanguage']);      &get_unprocessed_cgi($ENV{'QUERY_STRING'},['displaylanguage']);
Line 2905  sub display_languages { Line 3010  sub display_languages {
     return %languages;      return %languages;
 }  }
   
 sub preferred_languages {  
     my @languages=();  
     if ($env{'course.'.$env{'request.course.id'}.'.languages'}) {  
  @languages=(@languages,split(/\s*(\,|\;|\:)\s*/,  
          $env{'course.'.$env{'request.course.id'}.'.languages'}));  
     }  
     if ($env{'environment.languages'}) {  
  @languages=(@languages,  
     split(/\s*(\,|\;|\:)\s*/,$env{'environment.languages'}));  
     }  
     my $browser=$ENV{'HTTP_ACCEPT_LANGUAGE'};  
     if ($browser) {  
  my @browser =   
     map { (split(/\s*;\s*/,$_))[0] } (split(/\s*,\s*/,$browser));  
  push(@languages,@browser);  
     }  
   
     foreach my $domtype ($env{'user.domain'},$env{'request.role.domain'},  
                          $Apache::lonnet::perlvar{'lonDefDomain'}) {  
         if ($domtype ne '') {  
             my %domdefs = &Apache::lonnet::get_domain_defaults($domtype);  
             if ($domdefs{'lang_def'} ne '') {  
                 push(@languages,$domdefs{'lang_def'});  
             }  
         }  
     }  
 # turn "en-ca" into "en-ca,en"  
     my @genlanguages;  
     foreach my $lang (@languages) {  
  unless ($lang=~/\w/) { next; }  
  push(@genlanguages,$lang);  
  if ($lang=~/(\-|\_)/) {  
     push(@genlanguages,(split(/(\-|\_)/,$lang))[0]);  
  }  
     }  
     #uniqueify the languages list  
     my %count;  
     @genlanguages = map { $count{$_}++ == 0 ? $_ : () } @genlanguages;  
     return @genlanguages;  
 }  
   
 sub languages {  sub languages {
     my ($possible_langs) = @_;      my ($possible_langs) = @_;
     my @preferred_langs = &preferred_languages();      my @preferred_langs = &Apache::lonlocal::preferred_languages();
     if (!ref($possible_langs)) {      if (!ref($possible_langs)) {
  if( wantarray ) {   if( wantarray ) {
     return @preferred_langs;      return @preferred_langs;
Line 3292  sub pprmlink { Line 3356  sub pprmlink {
   
   
 sub timehash {  sub timehash {
     my @ltime=localtime(shift);      my ($thistime) = @_;
     return ( 'seconds' => $ltime[0],      my $timezone = &Apache::lonlocal::gettimezone();
              'minutes' => $ltime[1],      my $dt = DateTime->from_epoch(epoch => $thistime)
              'hours'   => $ltime[2],                       ->set_time_zone($timezone);
              'day'     => $ltime[3],      my $wday = $dt->day_of_week();
              'month'   => $ltime[4]+1,      if ($wday == 7) { $wday = 0; }
              'year'    => $ltime[5]+1900,      return ( 'second' => $dt->second(),
              'weekday' => $ltime[6],               'minute' => $dt->minute(),
              'dayyear' => $ltime[7]+1,               'hour'   => $dt->hour(),
              'dlsav'   => $ltime[8] );               'day'     => $dt->day_of_month(),
                'month'   => $dt->month(),
                'year'    => $dt->year(),
                'weekday' => $wday,
                'dayyear' => $dt->day_of_year(),
                'dlsav'   => $dt->is_dst() );
 }  }
   
 sub utc_string {  sub utc_string {
Line 3311  sub utc_string { Line 3380  sub utc_string {
   
 sub maketime {  sub maketime {
     my %th=@_;      my %th=@_;
       my ($epoch_time,$timezone,$dt);
       $timezone = &Apache::lonlocal::gettimezone();
       eval {
           $dt = DateTime->new( year   => $th{'year'},
                                month  => $th{'month'},
                                day    => $th{'day'},
                                hour   => $th{'hour'},
                                minute => $th{'minute'},
                                second => $th{'second'},
                                time_zone => $timezone,
                            );
       };
       if (!$@) {
           $epoch_time = $dt->epoch;
           if ($epoch_time) {
               return $epoch_time;
           }
       }
     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,-1));           $th{'day'},$th{'month'}-1,$th{'year'}-1900,0,0,-1));
Line 3691  sub blocking_status { Line 3778  sub blocking_status {
   
 ###############################################  ###############################################
   
   sub check_ip_acc {
       my ($acc)=@_;
       &Apache::lonxml::debug("acc is $acc");
       if (!defined($acc) || $acc =~ /^\s*$/ || $acc =~/^\s*no\s*$/i) {
           return 1;
       }
       my $allowed=0;
       my $ip=$env{'request.host'} || $ENV{'REMOTE_ADDR'};
   
       my $name;
       foreach my $pattern (split(',',$acc)) {
           $pattern =~ s/^\s*//;
           $pattern =~ s/\s*$//;
           if ($pattern =~ /\*$/) {
               #35.8.*
               $pattern=~s/\*//;
               if ($ip =~ /^\Q$pattern\E/) { $allowed=1; }
           } elsif ($pattern =~ /(\d+\.\d+\.\d+)\.\[(\d+)-(\d+)\]$/) {
               #35.8.3.[34-56]
               my $low=$2;
               my $high=$3;
               $pattern=$1;
               if ($ip =~ /^\Q$pattern\E/) {
                   my $last=(split(/\./,$ip))[3];
                   if ($last <=$high && $last >=$low) { $allowed=1; }
               }
           } elsif ($pattern =~ /^\*/) {
               #*.msu.edu
               $pattern=~s/\*//;
               if (!defined($name)) {
                   use Socket;
                   my $netaddr=inet_aton($ip);
                   ($name)=gethostbyaddr($netaddr,AF_INET);
               }
               if ($name =~ /\Q$pattern\E$/i) { $allowed=1; }
           } elsif ($pattern =~ /\d+\.\d+\.\d+\.\d+/) {
               #127.0.0.1
               if ($ip =~ /^\Q$pattern\E/) { $allowed=1; }
           } else {
               #some.name.com
               if (!defined($name)) {
                   use Socket;
                   my $netaddr=inet_aton($ip);
                   ($name)=gethostbyaddr($netaddr,AF_INET);
               }
               if ($name =~ /\Q$pattern\E$/i) { $allowed=1; }
           }
           if ($allowed) { last; }
       }
       return $allowed;
   }
   
   ###############################################
   
 =pod  =pod
   
 =head1 Domain Template Functions  =head1 Domain Template Functions
Line 3739  sub get_domainconf { Line 3880  sub get_domainconf {
         if (ref($domconfig{'login'}) eq 'HASH') {          if (ref($domconfig{'login'}) eq 'HASH') {
             if (keys(%{$domconfig{'login'}})) {              if (keys(%{$domconfig{'login'}})) {
                 foreach my $key (keys(%{$domconfig{'login'}})) {                  foreach my $key (keys(%{$domconfig{'login'}})) {
                     $designhash{$udom.'.login.'.$key}=$domconfig{'login'}{$key};                      if (ref($domconfig{'login'}{$key}) eq 'HASH') {
                           foreach my $img (keys(%{$domconfig{'login'}{$key}})) {
                               $designhash{$udom.'.login.'.$key.'_'.$img} =
                                   $domconfig{'login'}{$key}{$img};
                           }
                       } else {
                           $designhash{$udom.'.login.'.$key}=$domconfig{'login'}{$key};
                       }
                 }                  }
             } else {              } else {
                 $legacy{'login'} = 1;                  $legacy{'login'} = 1;
Line 4437  table.LC_docs_path td.LC_docs_path_compo Line 4585  table.LC_docs_path td.LC_docs_path_compo
 td.LC_table_cell_checkbox {  td.LC_table_cell_checkbox {
   text-align: center;    text-align: center;
 }  }
   
 table#LC_mainmenu td.LC_mainmenu_column {  table#LC_mainmenu td.LC_mainmenu_column {
     vertical-align: top;      vertical-align: top;
 }  }
Line 4451  table#LC_mainmenu td.LC_mainmenu_column Line 4598  table#LC_mainmenu td.LC_mainmenu_column
 .LC_menubuttons_link {  .LC_menubuttons_link {
   text-decoration: none;    text-decoration: none;
 }  }
   #2008--9-5: new menu style sheet.Changed category
 .LC_menubuttons_category {  .LC_menubuttons_category {
   color: $font;    color: $font;
   background: $pgbg;    background: $pgbg;
Line 4518  td.LC_menubuttons_img { Line 4665  td.LC_menubuttons_img {
   text-align: right;    text-align: right;
 }  }
   
   .LC_roleslog_note {
     font-size: smaller;
   }
   
   .LC_mail_functions {
       font-weight: bold;
   }
   
 table.LC_aboutme_port {  table.LC_aboutme_port {
   border: 0px;    border: 0px;
   border-collapse: collapse;    border-collapse: collapse;
Line 4550  table.LC_prior_tries tr th { Line 4705  table.LC_prior_tries tr th {
   background-color: $data_table_head;    background-color: $data_table_head;
   font-size: smaller;    font-size: smaller;
 }  }
   table.LC_data_table tr.LC_info_row > td {
     background-color: #CCC;
     font-weight: bold;
     text-align: left;
   }
 table.LC_data_table tr.LC_odd_row > td,   table.LC_data_table tr.LC_odd_row > td, 
 table.LC_aboutme_port tr td {  table.LC_aboutme_port tr td {
   background-color: $data_table_light;    background-color: $data_table_light;
Line 5300  hr.LC_edit_problem_divide { Line 5460  hr.LC_edit_problem_divide {
   height: 3px;    height: 3px;
   border: 0px;    border: 0px;
 }  }
   img.stift{
     border-width:0;
     vertical-align:middle;
   }
   
   table#LC_mainmenu{
    margin-top:10px;
    width:80%;
   
   }
   
   table#LC_mainmenu td.LC_mainmenu_col_fieldset{
     vertical-align: top;
     width: 45%;
   }
   .LC_mainmenu_fieldset_category {
     color: $font;
     background: $pgbg;
     font-family: $sans;
     font-size: small;
     font-weight: bold;
   }
   fieldset#LC_mainmenu_fieldset {
     margin:0px 10px 10px 0px;
   
   }
 END  END
 }  }
   
Line 6330  sub default_quota { Line 6516  sub default_quota {
         if ($inststatus ne '') {          if ($inststatus ne '') {
             my @statuses = split(/:/,$inststatus);              my @statuses = split(/:/,$inststatus);
             foreach my $item (@statuses) {              foreach my $item (@statuses) {
                 if ($quotahash{'quotas'}{$item} ne '') {                  if (ref($quotahash{'quotas'}{'defaultquota'}) eq 'HASH') {
                     if ($defquota eq '') {                      if ($quotahash{'quotas'}{'defaultquota'}{$item} ne '') {
                         $defquota = $quotahash{'quotas'}{$item};                          if ($defquota eq '') {
                         $settingstatus = $item;                              $defquota = $quotahash{'quotas'}{'defaultquota'}{$item};
                     } elsif ($quotahash{'quotas'}{$item} > $defquota) {                              $settingstatus = $item;
                         $defquota = $quotahash{'quotas'}{$item};                          } elsif ($quotahash{'quotas'}{'defaultquota'}{$item} > $defquota) {
                         $settingstatus = $item;                              $defquota = $quotahash{'quotas'}{'defaultquota'}{$item};
                               $settingstatus = $item;
                           }
                       }
                   } else {
                       if ($quotahash{'quotas'}{$item} ne '') {
                           if ($defquota eq '') {
                               $defquota = $quotahash{'quotas'}{$item};
                               $settingstatus = $item;
                           } elsif ($quotahash{'quotas'}{$item} > $defquota) {
                               $defquota = $quotahash{'quotas'}{$item};
                               $settingstatus = $item;
                           }
                     }                      }
                 }                  }
             }              }
         }          }
         if ($defquota eq '') {          if ($defquota eq '') {
             $defquota = $quotahash{'quotas'}{'default'};              if (ref($quotahash{'quotas'}{'defaultquota'}) eq 'HASH') {
                   $defquota = $quotahash{'quotas'}{'defaultquota'}{'default'};
               } else {
                   $defquota = $quotahash{'quotas'}{'default'};
               }
             $settingstatus = 'default';              $settingstatus = 'default';
         }          }
     } else {      } else {
Line 6748  sub instrule_disallow_msg { Line 6950  sub instrule_disallow_msg {
             $text{'action'} = 'IDs';              $text{'action'} = 'IDs';
         }          }
     }      }
     $response = &mt("The $text{'item'} you chose $text{'match'} the format of $text{'items'} defined for <span class=\"LC_cusr_emph\">[_1]</span>, but the $text{'item'} $text{'do'} not exist in the institutional directory.",$domdesc).'<br />';      $response = &mt("The $text{'item'} you chose $text{'match'} the format of $text{'items'} defined for [_1], but the $text{'item'} $text{'do'} not exist in the institutional directory.",'<span class="LC_cusr_emph">'.$domdesc.'</span>').'<br />';
     if ($mode eq 'upload') {      if ($mode eq 'upload') {
         if ($checkitem eq 'username') {          if ($checkitem eq 'username') {
             $response .= &mt("You will need to modify your upload file so it will include $text{'action'} with a different format --  $text{'one'} that will not conflict with 'official' institutional $text{'items'}.");              $response .= &mt("You will need to modify your upload file so it will include $text{'action'} with a different format --  $text{'one'} that will not conflict with 'official' institutional $text{'items'}.");
         } elsif ($checkitem eq 'id') {          } elsif ($checkitem eq 'id') {
             $response .= &mt("Either upload a file which includes $text{'action'} with a different format --  $text{'one'} that will not conflict with 'official' institutional $text{'items'}, or when associating fields with data columns, omit an association for the ID/Student Number field.");              $response .= &mt("Either upload a file which includes $text{'action'} with a different format --  $text{'one'} that will not conflict with 'official' institutional $text{'items'}, or when associating fields with data columns, omit an association for the Student/Employee ID field.");
           }
       } elsif ($mode eq 'selfcreate') {
           if ($checkitem eq 'id') {
               $response .= &mt("You must either choose $text{'action'} with a different format --  $text{'one'} that will not conflict with 'official' institutional $text{'items'}, or leave the ID field blank.");
         }          }
     } else {      } else {
         if ($checkitem eq 'username') {          if ($checkitem eq 'username') {
Line 6783  sub sorted_inst_types { Line 6989  sub sorted_inst_types {
     my ($usertypes,$order) = &Apache::lonnet::retrieve_inst_usertypes($dom);      my ($usertypes,$order) = &Apache::lonnet::retrieve_inst_usertypes($dom);
     my $othertitle = &mt('All users');      my $othertitle = &mt('All users');
     if ($env{'request.course.id'}) {      if ($env{'request.course.id'}) {
         $othertitle  = 'any';          $othertitle  = &mt('Any users');
     }      }
     my @types;      my @types;
     if (ref($order) eq 'ARRAY') {      if (ref($order) eq 'ARRAY') {
Line 6796  sub sorted_inst_types { Line 7002  sub sorted_inst_types {
     }      }
     if (keys(%{$usertypes}) > 0) {      if (keys(%{$usertypes}) > 0) {
         $othertitle = &mt('Other users');          $othertitle = &mt('Other users');
         if ($env{'request.course.id'}) {  
             $othertitle = 'other';  
         }  
     }      }
     return ($othertitle,$usertypes,\@types);      return ($othertitle,$usertypes,\@types);
 }  }
Line 6984  sub get_env_multiple { Line 7187  sub get_env_multiple {
     return(@values);      return(@values);
 }  }
   
   sub ask_for_embedded_content {
       my ($actionurl,$state,$allfiles,$codebase,$args)=@_;
       my $upload_output = '
      <form name="upload_embedded" action="'.$actionurl.'"
                     method="post" enctype="multipart/form-data">';
       $upload_output .= $state;
       $upload_output .= '<b>Upload embedded files</b>:<br />'.&start_data_table();
   
       my $num = 0;
       foreach my $embed_file (sort {lc($a) cmp lc($b)} keys(%{$allfiles})) {
           $upload_output .= &start_data_table_row().
               '<td>'.$embed_file.'</td><td>';
           if ($args->{'ignore_remote_references'}
               && $embed_file =~ m{^\w+://}) {
               $upload_output.='<span class="LC_warning">'.&mt("URL points to other server.").'</span>';
           } elsif ($args->{'error_on_invalid_names'}
               && $embed_file ne &Apache::lonnet::clean_filename($embed_file,{'keep_path' => 1,})) {
   
               $upload_output.='<span class="LC_warning">'.&mt("Invalid characters").'</span>';
   
           } else {
               $upload_output .='
              <input name="embedded_item_'.$num.'" type="file" value="" />
              <input name="embedded_orig_'.$num.'" type="hidden" value="'.&escape($embed_file).'" />';
               my $attrib = join(':',@{$$allfiles{$embed_file}});
               $upload_output .=
                   "\n\t\t".
                   '<input name="embedded_attrib_'.$num.'" type="hidden" value="'.
                   $attrib.'" />';
               if (exists($$codebase{$embed_file})) {
                   $upload_output .=
                       "\n\t\t".
                       '<input name="codebase_'.$num.'" type="hidden" value="'.
                       &escape($$codebase{$embed_file}).'" />';
               }
           }
           $upload_output .= '</td>'.&Apache::loncommon::end_data_table_row();
           $num++;
       }
       $upload_output .= &Apache::loncommon::end_data_table().'<br />
      <input type ="hidden" name="number_embedded_items" value="'.$num.'" />
      <input type ="submit" value="'.&mt('Upload Listed Files').'" />
      '.&mt('(only files for which a location has been provided will be uploaded)').'
      </form>';
       return $upload_output;
   }
   
   sub upload_embedded {
       my ($context,$dirpath,$uname,$udom,$dir_root,$url_root,$group,$disk_quota,
           $current_disk_usage) = @_;
       my $output;
       for (my $i=0; $i<$env{'form.number_embedded_items'}; $i++) {
           next if (!exists($env{'form.embedded_item_'.$i.'.filename'}));
           my $orig_uploaded_filename =
               $env{'form.embedded_item_'.$i.'.filename'};
   
           $env{'form.embedded_orig_'.$i} =
               &unescape($env{'form.embedded_orig_'.$i});
           my ($path,$fname) =
               ($env{'form.embedded_orig_'.$i} =~ m{(.*/)([^/]*)});
           # no path, whole string is fname
           if (!$fname) { $fname = $env{'form.embedded_orig_'.$i} };
   
           $path = $env{'form.currentpath'}.$path;
           $fname = &Apache::lonnet::clean_filename($fname);
           # See if there is anything left
           next if ($fname eq '');
   
           # Check if file already exists as a file or directory.
           my ($state,$msg);
           if ($context eq 'portfolio') {
               my $port_path = $dirpath;
               if ($group ne '') {
                   $port_path = "groups/$group/$port_path";
               }
               ($state,$msg) = &check_for_upload($path,$fname,$group,'embedded_item_'.$i,
                                                 $dir_root,$port_path,$disk_quota,
                                                 $current_disk_usage,$uname,$udom);
               if ($state eq 'will_exceed_quota'
                   || $state eq 'file_locked'
                   || $state eq 'file_exists' ) {
                   $output .= $msg;
                   next;
               }
           } elsif (($context eq 'author') || ($context eq 'testbank')) {
               ($state,$msg) = &check_for_existing($path,$fname,'embedded_item_'.$i);
               if ($state eq 'exists') {
                   $output .= $msg;
                   next;
               }
           }
           # Check if extension is valid
           if (($fname =~ /\.(\w+)$/) &&
               (&Apache::loncommon::fileembstyle($1) eq 'hdn')) {
               $output .= &mt('Invalid file extension ([_1]) - reserved for LONCAPA use - rename the file with a different extension and re-upload. ',$1);
               next;
           } elsif (($fname =~ /\.(\w+)$/) &&
                    (!defined(&Apache::loncommon::fileembstyle($1)))) {
               $output .= &mt('Unrecognized file extension ([_1]) - rename the file with a proper extension and re-upload.',$1);
               next;
           } elsif ($fname=~/\.(\d+)\.(\w+)$/) {
               $output .= &mt('File name not allowed - rename the file to remove the number immediately before the file extension([_1]) and re-upload.',$2);
               next;
           }
   
           $env{'form.embedded_item_'.$i.'.filename'}=$fname;
           if ($context eq 'portfolio') {
               my $result=
                   &Apache::lonnet::userfileupload('embedded_item_'.$i,'',
                                                   $dirpath.$path);
               if ($result !~ m|^/uploaded/|) {
                   $output .= '<span class="LC_error">'
                         .&mt('An error occurred ([_1]) while trying to upload [_2] for embedded element [_3].'
                              ,$result,$orig_uploaded_filename,$env{'form.embedded_orig_'.$i})
                         .'</span><br />';
                   next;
               } else {
                   $output .= '<p>'.&mt('Uploaded [_1]','<span class="LC_filename">'.
                              $path.$fname.'</span>').'</p>';     
               }
           } else {
   # Save the file
               my $target = $env{'form.embedded_item_'.$i};
               my $fullpath = $dir_root.$dirpath.'/'.$path;
               my $dest = $fullpath.$fname;
               my $url = $url_root.$dirpath.'/'.$path.$fname;
               my @parts=split(/\//,$fullpath);
               my $count;
               my $filepath = $dir_root;
               for ($count=4;$count<=$#parts;$count++) {
                   $filepath .= "/$parts[$count]";
                   if ((-e $filepath)!=1) {
                       mkdir($filepath,0770);
                   }
               }
               my $fh;
               if (!open($fh,'>'.$dest)) {
                   &Apache::lonnet::logthis('Failed to create '.$dest);
                   $output .= '<span class="LC_error">'.
                              &mt('An error occurred while trying to upload [_1] for embedded element [_2].',$orig_uploaded_filename,$env{'form.embedded_orig_'.$i}).
                              '</span><br />';
               } else {
                   if (!print $fh $env{'form.embedded_item_'.$i}) {
                       &Apache::lonnet::logthis('Failed to write to '.$dest);
                       $output .= '<span class="LC_error">'.
                                 &mt('An error occurred while writing the file [_1] for embedded element [_2].',$orig_uploaded_filename,$env{'form.embedded_orig_'.$i}).
                                 '</span><br />';
                   } else {
                       if ($context eq 'testbank') {
                           $output .= &mt('Embedded file uploaded successfully:').
                                      '&nbsp;<a href="'.$url.'">'.
                                      $orig_uploaded_filename.'</a><br />';
                       } else {
                           $output .= '<font size="+2">'.
                                      &mt('View embedded file: [_1]','<a href="'.$url.'">'.
                                      $orig_uploaded_filename.'</a>').'</font><br />';
                       }
                   }
                   close($fh);
               }
           }
       }
       return $output;
   }
   
   sub check_for_existing {
       my ($path,$fname,$element) = @_;
       my ($state,$msg);
       if (-d $path.'/'.$fname) {
           $state = 'exists';
           $msg = &mt('Unable to upload [_1]. A directory by that name was found in [_2].','<span class="LC_filename">'.$fname.'</span>',$path);
       } elsif (-e $path.'/'.$fname) {
           $state = 'exists';
           $msg = &mt('Unable to upload [_1]. A file by that name was found in [_2].','<span class="LC_filename">'.$fname.'</span>',$path);
       }
       if ($state eq 'exists') {
           $msg = '<span class="LC_error">'.$msg.'</span><br />';
       }
       return ($state,$msg);
   }
   
   sub check_for_upload {
       my ($path,$fname,$group,$element,$portfolio_root,$port_path,
           $disk_quota,$current_disk_usage,$uname,$udom) = @_;
       my $filesize = (length($env{'form.'.$element})) / 1000; #express in k (1024?)
       my $getpropath = 1;
       my @dir_list = &Apache::lonnet::dirlist($portfolio_root.$path,$udom,$uname,
                                               $getpropath);
       my $found_file = 0;
       my $locked_file = 0;
       foreach my $line (@dir_list) {
           my ($file_name)=split(/\&/,$line,2);
           if ($file_name eq $fname){
               $file_name = $path.$file_name;
               if ($group ne '') {
                   $file_name = $group.$file_name;
               }
               $found_file = 1;
               if (&Apache::lonnet::is_locked($file_name,$udom,$uname) eq 'true') {
                   $locked_file = 1;
               }
           }
       }
       if (($current_disk_usage + $filesize) > $disk_quota){
           my $msg = '<span class="LC_error">'.
                   &mt('Unable to upload [_1]. (size = [_2] kilobytes). Disk quota will be exceeded.','<span class="LC_filename">'.$fname.'</span>',$filesize).'</span>'.
                     '<br />'.&mt('Disk quota is [_1] kilobytes. Your current disk usage is [_2] kilobytes.',$disk_quota,$current_disk_usage);
           return ('will_exceed_quota',$msg);
       } elsif ($found_file) {
           if ($locked_file) {
               my $msg = '<span class="LC_error">';
               $msg .= &mt('Unable to upload [_1]. A locked file by that name was found in [_2].','<span class="LC_filename">'.$fname.'</span>','<span class="LC_filename">'.$port_path.$env{'form.currentpath'}.'</span>');
               $msg .= '</span><br />';
               $msg .= &mt('You will be able to rename or delete existing [_1] after a grade has been assigned.','<span class="LC_filename">'.$fname.'</span>');
               return ('file_locked',$msg);
           } else {
               my $msg = '<span class="LC_error">';
               $msg .= &mt('Unable to upload [_1]. A file by that name was found in [_2].','<span class="LC_filename">'.$fname.'</span>',$port_path.$env{'form.currentpath'});
               $msg .= '</span>';
               $msg .= '<br />';
               $msg .= &mt('To upload, rename or delete existing [_1] in [_2].','<span class="LC_filename">'.$fname.'</span>', $port_path.$env{'form.currentpath'});
               return ('file_exists',$msg);
           }
       }
   }
   
   
 =pod  =pod
   
Line 7213  Apache Request ref, $records is an array Line 7642  Apache Request ref, $records is an array
 ######################################################  ######################################################
 sub csv_print_samples {  sub csv_print_samples {
     my ($r,$records) = @_;      my ($r,$records) = @_;
     my $samples = &get_samples($records,3);      my $samples = &get_samples($records,5);
   
     $r->print(&mt('Samples').'<br />'.&start_data_table().      $r->print(&mt('Samples').'<br />'.&start_data_table().
               &start_data_table_header_row());                &start_data_table_header_row());
Line 7260  sub csv_print_select_table { Line 7689  sub csv_print_select_table {
               &end_data_table_header_row()."\n");                &end_data_table_header_row()."\n");
     foreach my $array_ref (@$d) {      foreach my $array_ref (@$d) {
  my ($value,$display,$defaultcol)=@{ $array_ref };   my ($value,$display,$defaultcol)=@{ $array_ref };
  $r->print(&start_data_table_row().'<tr><td>'.$display.'</td>');   $r->print(&start_data_table_row().'<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.');">');
Line 7268  sub csv_print_select_table { Line 7697  sub csv_print_select_table {
  foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) {   foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
     $r->print('<option value="'.$sample.'"'.      $r->print('<option value="'.$sample.'"'.
                       ($sample eq $defaultcol ? ' selected="selected" ' : '').                        ($sample eq $defaultcol ? ' selected="selected" ' : '').
                       '>Column '.($sample+1).'</option>');                        '>'.&mt('Column [_1]',($sample+1)).'</option>');
  }   }
  $r->print('</select></td>'.&end_data_table_row()."\n");   $r->print('</select></td>'.&end_data_table_row()."\n");
  $i++;   $i++;
Line 7299  sub csv_samples_select_table { Line 7728  sub csv_samples_select_table {
     my ($r,$records,$d) = @_;      my ($r,$records,$d) = @_;
     my $i=0;      my $i=0;
     #      #
     my $samples = &get_samples($records,3);      my $max_samples = 5;
       my $samples = &get_samples($records,$max_samples);
     $r->print(&start_data_table().      $r->print(&start_data_table().
               &start_data_table_header_row().'<th>'.                &start_data_table_header_row().'<th>'.
               &mt('Field').'</th><th>'.&mt('Samples').'</th>'.                &mt('Field').'</th><th>'.&mt('Samples').'</th>'.
Line 7315  sub csv_samples_select_table { Line 7745  sub csv_samples_select_table {
                       $display.'</option>');                        $display.'</option>');
  }   }
  $r->print('</select></td><td>');   $r->print('</select></td><td>');
  foreach my $line (0..2) {   foreach my $line (0..($max_samples-1)) {
     if (defined($samples->[$line]{$key})) {       if (defined($samples->[$line]{$key})) { 
  $r->print($samples->[$line]{$key}."<br />\n");    $r->print($samples->[$line]{$key}."<br />\n"); 
     }      }
Line 7926  defdom (domain for which to retrieve con Line 8356  defdom (domain for which to retrieve con
 origmail (scalar - email address of recipient from loncapa.conf,   origmail (scalar - email address of recipient from loncapa.conf, 
 i.e., predates configuration by DC via domainprefs.pm   i.e., predates configuration by DC via domainprefs.pm 
   
 Returns: comma separated list of addresses to which to send e-mail.     Returns: comma separated list of addresses to which to send e-mail.
   
   =back
   
 =cut  =cut
   
Line 7954  sub build_recipient_list { Line 8386  sub build_recipient_list {
     } elsif ($origmail ne '') {      } elsif ($origmail ne '') {
         push(@recipients,$origmail);          push(@recipients,$origmail);
     }      }
     if ($defmail ne '') {      if (defined($defmail)) {
         push(@recipients,$defmail);          if ($defmail ne '') {
               push(@recipients,$defmail);
           }
     }      }
     if ($otheremails) {      if ($otheremails) {
         my @others;          my @others;
Line 7977  sub build_recipient_list { Line 8411  sub build_recipient_list {
 ############################################################  ############################################################
 ############################################################  ############################################################
   
   =pod
   
   =head1 Course Catalog Routines
   
   =over 4
   
   =item * &gather_categories()
   
   Converts category definitions - keys of categories hash stored in  
   coursecategories in configuration.db on the primary library server in a 
   domain - to an array.  Also generates javascript and idx hash used to 
   generate Domain Coordinator interface for editing Course Categories.
   
   Inputs:
   
   categories (reference to hash of category definitions).
   
   cats (reference to array of arrays/hashes which encapsulates hierarchy of
         categories and subcategories).
   
   idx (reference to hash of counters used in Domain Coordinator interface for 
         editing Course Categories).
   
   jsarray (reference to array of categories used to create Javascript arrays for
            Domain Coordinator interface for editing Course Categories).
   
   Returns: nothing
   
   Side effects: populates cats, idx and jsarray. 
   
   =cut
   
   sub gather_categories {
       my ($categories,$cats,$idx,$jsarray) = @_;
       my %counters;
       my $num = 0;
       foreach my $item (keys(%{$categories})) {
           my ($cat,$container,$depth) = map { &unescape($_); } split(/:/,$item);
           if ($container eq '' && $depth == 0) {
               $cats->[$depth][$categories->{$item}] = $cat;
           } else {
               $cats->[$depth]{$container}[$categories->{$item}] = $cat;
           }
           my ($escitem,$tail) = split(/:/,$item,2);
           if ($counters{$tail} eq '') {
               $counters{$tail} = $num;
               $num ++;
           }
           if (ref($idx) eq 'HASH') {
               $idx->{$item} = $counters{$tail};
           }
           if (ref($jsarray) eq 'ARRAY') {
               push(@{$jsarray->[$counters{$tail}]},$item);
           }
       }
       return;
   }
   
   =pod
   
   =item * &extract_categories()
   
   Used to generate breadcrumb trails for course categories.
   
   Inputs:
   
   categories (reference to hash of category definitions).
   
   cats (reference to array of arrays/hashes which encapsulates hierarchy of
         categories and subcategories).
   
   trails (reference to array of breacrumb trails for each category).
   
   allitems (reference to hash - key is category key 
            (format: escaped(name):escaped(parent category):depth in hierarchy).
   
   idx (reference to hash of counters used in Domain Coordinator interface for
         editing Course Categories).
   
   jsarray (reference to array of categories used to create Javascript arrays for
            Domain Coordinator interface for editing Course Categories).
   
   subcats (reference to hash of arrays containing all subcategories within each 
            category, -recursive)
   
   Returns: nothing
   
   Side effects: populates trails and allitems hash references.
   
   =cut
   
   sub extract_categories {
       my ($categories,$cats,$trails,$allitems,$idx,$jsarray,$subcats) = @_;
       if (ref($categories) eq 'HASH') {
           &gather_categories($categories,$cats,$idx,$jsarray);
           if (ref($cats->[0]) eq 'ARRAY') {
               for (my $i=0; $i<@{$cats->[0]}; $i++) {
                   my $name = $cats->[0][$i];
                   my $item = &escape($name).'::0';
                   my $trailstr;
                   if ($name eq 'instcode') {
                       $trailstr = &mt('Official courses (with institutional codes)');
                   } else {
                       $trailstr = $name;
                   }
                   if ($allitems->{$item} eq '') {
                       push(@{$trails},$trailstr);
                       $allitems->{$item} = scalar(@{$trails})-1;
                   }
                   my @parents = ($name);
                   if (ref($cats->[1]{$name}) eq 'ARRAY') {
                       for (my $j=0; $j<@{$cats->[1]{$name}}; $j++) {
                           my $category = $cats->[1]{$name}[$j];
                           if (ref($subcats) eq 'HASH') {
                               push(@{$subcats->{$item}},&escape($category).':'.&escape($name).':1');
                           }
                           &recurse_categories($cats,2,$category,$trails,$allitems,\@parents,$subcats);
                       }
                   } else {
                       if (ref($subcats) eq 'HASH') {
                           $subcats->{$item} = [];
                       }
                   }
               }
           }
       }
       return;
   }
   
   =pod
   
   =item *&recurse_categories()
   
   Recursively used to generate breadcrumb trails for course categories.
   
   Inputs:
   
   cats (reference to array of arrays/hashes which encapsulates hierarchy of
         categories and subcategories).
   
   depth (current depth in hierarchy of categories and sub-categories - 0 indexed).
   
   category (current course category, for which breadcrumb trail is being generated).
   
   trails (reference to array of breadcrumb trails for each category).
   
   allitems (reference to hash - key is category key
            (format: escaped(name):escaped(parent category):depth in hierarchy).
   
   parents (array containing containers directories for current category, 
            back to top level). 
   
   Returns: nothing
   
   Side effects: populates trails and allitems hash references
   
   =cut
   
   sub recurse_categories {
       my ($cats,$depth,$category,$trails,$allitems,$parents,$subcats) = @_;
       my $shallower = $depth - 1;
       if (ref($cats->[$depth]{$category}) eq 'ARRAY') {
           for (my $k=0; $k<@{$cats->[$depth]{$category}}; $k++) {
               my $name = $cats->[$depth]{$category}[$k];
               my $item = &escape($category).':'.&escape($parents->[-1]).':'.$shallower;
               my $trailstr = join(' -&gt; ',(@{$parents},$category));
               if ($allitems->{$item} eq '') {
                   push(@{$trails},$trailstr);
                   $allitems->{$item} = scalar(@{$trails})-1;
               }
               my $deeper = $depth+1;
               push(@{$parents},$category);
               if (ref($subcats) eq 'HASH') {
                   my $subcat = &escape($name).':'.$category.':'.$depth;
                   for (my $j=@{$parents}; $j>=0; $j--) {
                       my $higher;
                       if ($j > 0) {
                           $higher = &escape($parents->[$j]).':'.
                                     &escape($parents->[$j-1]).':'.$j;
                       } else {
                           $higher = &escape($parents->[$j]).'::'.$j;
                       }
                       push(@{$subcats->{$higher}},$subcat);
                   }
               }
               &recurse_categories($cats,$deeper,$name,$trails,$allitems,$parents,
                                   $subcats);
               pop(@{$parents});
           }
       } else {
           my $item = &escape($category).':'.&escape($parents->[-1]).':'.$shallower;
           my $trailstr = join(' -&gt; ',(@{$parents},$category));
           if ($allitems->{$item} eq '') {
               push(@{$trails},$trailstr);
               $allitems->{$item} = scalar(@{$trails})-1;
           }
       }
       return;
   }
   
   =pod
   
   =item *&assign_categories_table()
   
   Create a datatable for display of hierarchical categories in a domain,
   with checkboxes to allow a course to be categorized. 
   
   Inputs:
   
   cathash - reference to hash of categories defined for the domain (from
             configuration.db)
   
   currcat - scalar with an & separated list of categories assigned to a course. 
   
   Returns: $output (markup to be displayed) 
   
   =cut
   
   sub assign_categories_table {
       my ($cathash,$currcat) = @_;
       my $output;
       if (ref($cathash) eq 'HASH') {
           my (@cats,@trails,%allitems,%idx,@jsarray,@path,$maxdepth);
           &extract_categories($cathash,\@cats,\@trails,\%allitems,\%idx,\@jsarray);
           $maxdepth = scalar(@cats);
           if (@cats > 0) {
               my $itemcount = 0;
               if (ref($cats[0]) eq 'ARRAY') {
                   $output = &Apache::loncommon::start_data_table();
                   my @currcategories;
                   if ($currcat ne '') {
                       @currcategories = split('&',$currcat);
                   }
                   for (my $i=0; $i<@{$cats[0]}; $i++) {
                       my $parent = $cats[0][$i];
                       my $css_class = $itemcount%2?' class="LC_odd_row"':'';
                       next if ($parent eq 'instcode');
                       my $item = &escape($parent).'::0';
                       my $checked = '';
                       if (@currcategories > 0) {
                           if (grep(/^\Q$item\E$/,@currcategories)) {
                               $checked = ' checked="checked" ';
                           }
                       }
                       $output .= '<tr '.$css_class.'><td><span class="LC_nobreak">'.
                                  '<input type="checkbox" name="usecategory" value="'.
                                  $item.'"'.$checked.' />'.$parent.'</span>'.
                                  '<input type="hidden" name="catname" value="'.$parent.'" /></td>';
                       my $depth = 1;
                       push(@path,$parent);
                       $output .= &assign_category_rows($itemcount,\@cats,$depth,$parent,\@path,\@currcategories);
                       pop(@path);
                       $output .= '</tr><tr><td colspan="'.$maxdepth.'" class="LC_row_separator"></td></tr>';
                       $itemcount ++;
                   }
                   $output .= &Apache::loncommon::end_data_table();
               }
           }
       }
       return $output;
   }
   
   =pod
   
   =item *&assign_category_rows()
   
   Create a datatable row for display of nested categories in a domain,
   with checkboxes to allow a course to be categorized,called recursively.
   
   Inputs:
   
   itemcount - track row number for alternating colors
   
   cats - reference to array of arrays/hashes which encapsulates hierarchy of
         categories and subcategories.
   
   depth - current depth in hierarchy of categories and sub-categories - 0 indexed.
   
   parent - parent of current category item
   
   path - Array containing all categories back up through the hierarchy from the
          current category to the top level.
   
   currcategories - reference to array of current categories assigned to the course
   
   Returns: $output (markup to be displayed).
   
   =cut
   
   sub assign_category_rows {
       my ($itemcount,$cats,$depth,$parent,$path,$currcategories) = @_;
       my ($text,$name,$item,$chgstr);
       if (ref($cats) eq 'ARRAY') {
           my $maxdepth = scalar(@{$cats});
           if (ref($cats->[$depth]) eq 'HASH') {
               if (ref($cats->[$depth]{$parent}) eq 'ARRAY') {
                   my $numchildren = @{$cats->[$depth]{$parent}};
                   my $css_class = $itemcount%2?' class="LC_odd_row"':'';
                   $text .= '<td><table class="LC_datatable">';
                   for (my $j=0; $j<$numchildren; $j++) {
                       $name = $cats->[$depth]{$parent}[$j];
                       $item = &escape($name).':'.&escape($parent).':'.$depth;
                       my $deeper = $depth+1;
                       my $checked = '';
                       if (ref($currcategories) eq 'ARRAY') {
                           if (@{$currcategories} > 0) {
                               if (grep(/^\Q$item\E$/,@{$currcategories})) {
                                   $checked = ' checked="checked" ';
                               }
                           }
                       }
                       $text .= '<tr><td><span class="LC_nobreak"><label>'.
                                '<input type="checkbox" name="usecategory" value="'.
                                $item.'"'.$checked.' />'.$name.'</label></span>'.
                                '<input type="hidden" name="catname" value="'.$name.'" />'.
                                '</td><td>';
                       if (ref($path) eq 'ARRAY') {
                           push(@{$path},$name);
                           $text .= &assign_category_rows($itemcount,$cats,$deeper,$name,$path,$currcategories);
                           pop(@{$path});
                       }
                       $text .= '</td></tr>';
                   }
                   $text .= '</table></td>';
               }
           }
       }
       return $text;
   }
   
   ############################################################
   ############################################################
   
   
 sub commit_customrole {  sub commit_customrole {
     my ($udom,$uname,$url,$three,$four,$five,$start,$end) = @_;      my ($udom,$uname,$url,$three,$four,$five,$start,$end,$context) = @_;
     my $output = &mt('Assigning custom role').' "'.$five.'" by '.$four.':'.$three.' in '.$url.      my $output = &mt('Assigning custom role').' "'.$five.'" by '.$four.':'.$three.' in '.$url.
                          ($start?', '.&mt('starting').' '.localtime($start):'').                           ($start?', '.&mt('starting').' '.localtime($start):'').
                          ($end?', ending '.localtime($end):'').': <b>'.                           ($end?', ending '.localtime($end):'').': <b>'.
               &Apache::lonnet::assigncustomrole(                &Apache::lonnet::assigncustomrole(
                  $udom,$uname,$url,$three,$four,$five,$end,$start).                   $udom,$uname,$url,$three,$four,$five,$end,$start,undef,undef,$context).
                  '</b><br />';                   '</b><br />';
     return $output;      return $output;
 }  }
Line 8018  sub commit_standardrole { Line 8786  sub commit_standardrole {
         $output = &mt('Assigning').' '.$three.' in '.$url.          $output = &mt('Assigning').' '.$three.' in '.$url.
                ($start?', '.&mt('starting').' '.localtime($start):'').                 ($start?', '.&mt('starting').' '.localtime($start):'').
                ($end?', '.&mt('ending').' '.localtime($end):'').': ';                 ($end?', '.&mt('ending').' '.localtime($end):'').': ';
         my $result = &Apache::lonnet::assignrole($udom,$uname,$url,$three,$end,$start);          my $result = &Apache::lonnet::assignrole($udom,$uname,$url,$three,$end,$start,'','',$context);
         if ($context eq 'auto') {          if ($context eq 'auto') {
             $output .= $result.$linefeed;              $output .= $result.$linefeed;
         } else {          } else {
Line 8053  sub commit_studentrole { Line 8821  sub commit_studentrole {
                 }                  }
                 $oldsecurl = $uurl;                  $oldsecurl = $uurl;
                 $expire_role_result =                   $expire_role_result = 
                     &Apache::lonnet::assignrole($udom,$uname,$uurl,'st',$now);                      &Apache::lonnet::assignrole($udom,$uname,$uurl,'st',$now,'','',$context);
                 if ($env{'request.course.sec'} ne '') {                   if ($env{'request.course.sec'} ne '') { 
                     if ($expire_role_result eq 'refused') {                      if ($expire_role_result eq 'refused') {
                         my @roles = ('st');                          my @roles = ('st');
Line 8076  sub commit_studentrole { Line 8844  sub commit_studentrole {
             }              }
         }          }
         if (($expire_role_result eq 'ok') || ($secchange == 0)) {          if (($expire_role_result eq 'ok') || ($secchange == 0)) {
             $modify_section_result = &Apache::lonnet::modify_student_enrollment($udom,$uname,undef,undef,undef,undef,undef,$sec,$end,$start,'','',$cid);              $modify_section_result = &Apache::lonnet::modify_student_enrollment($udom,$uname,undef,undef,undef,undef,undef,$sec,$end,$start,'','',$cid,'',$context);
             if ($modify_section_result =~ /^ok/) {              if ($modify_section_result =~ /^ok/) {
                 if ($secchange == 1) {                  if ($secchange == 1) {
                     if ($sec eq '') {                      if ($sec eq '') {
Line 8485  sub construct_course { Line 9253  sub construct_course {
         $outcome .= ($fatal?$errtext:'read ok').' - ';          $outcome .= ($fatal?$errtext:'read ok').' - ';
         my $title; my $url;          my $title; my $url;
         if ($args->{'firstres'} eq 'syl') {          if ($args->{'firstres'} eq 'syl') {
     $title='Syllabus';      $title=&mt('Syllabus');
             $url='/public/'.$$crsudom.'/'.$$crsunum.'/syllabus';              $url='/public/'.$$crsudom.'/'.$$crsunum.'/syllabus';
         } else {          } else {
             $title='Navigate Contents';              $title=&mt('Navigate Contents');
             $url='/adm/navmaps';              $url='/adm/navmaps';
         }          }
   
Line 8542  sub icon { Line 9310  sub icon {
     return &lonhttpdurl($iconname);      return &lonhttpdurl($iconname);
 }   } 
   
 sub lonhttpd_port {  
     my $lonhttpd_port=$Apache::lonnet::perlvar{'lonhttpdPort'};  
     if (!defined($lonhttpd_port)) { $lonhttpd_port='8080'; }  
     # IE doesn't like a secure page getting images from a non-secure  
     # port (when logging we haven't parsed the browser type so default  
     # back to secure  
     if ((!exists($env{'browser.type'}) || $env{'browser.type'} eq 'explorer')  
  && $ENV{'SERVER_PORT'} == 443) {  
  return 443;  
     }  
     return $lonhttpd_port;  
   
 }  
   
 sub lonhttpdurl {  sub lonhttpdurl {
   #
   # Had been used for "small fry" static images on separate port 8080.
   # Modify here if lightweight http functionality desired again.
   # Currently eliminated due to increasing firewall issues.
   #
     my ($url)=@_;      my ($url)=@_;
       return $url;
     my $lonhttpd_port = &lonhttpd_port();  
     if ($lonhttpd_port == 443) {  
  return 'https://'.$ENV{'SERVER_NAME'}.$url;  
     }  
     return 'http://'.$ENV{'SERVER_NAME'}.':'.$lonhttpd_port.$url;  
 }  }
   
 sub connection_aborted {  sub connection_aborted {
Line 8641  sub init_user_environment { Line 9395  sub init_user_environment {
  }   }
 # Give them a new cookie  # Give them a new cookie
  my $id = ($args->{'robot'} ? 'robot'.$args->{'robot'}   my $id = ($args->{'robot'} ? 'robot'.$args->{'robot'}
                    : $now);                     : $now.$$.int(rand(10000)));
  $cookie="$username\_$id\_$domain\_$authhost";   $cookie="$username\_$id\_$domain\_$authhost";
           
 # Initialize roles  # Initialize roles
Line 8756  sub init_user_environment { Line 9510  sub init_user_environment {
   
 sub _add_to_env {  sub _add_to_env {
     my ($idf,$env_data,$prefix) = @_;      my ($idf,$env_data,$prefix) = @_;
     while (my ($key,$value) = each(%$env_data)) {      if (ref($env_data) eq 'HASH') {
  $idf->{$prefix.$key} = $value;          while (my ($key,$value) = each(%$env_data)) {
  $env{$prefix.$key}   = $value;      $idf->{$prefix.$key} = $value;
       $env{$prefix.$key}   = $value;
           }
       }
   }
   
   # --- Get the symbolic name of a problem and the url
   sub get_symb {
       my ($request,$silent) = @_;
       (my $url=$env{'form.url'}) =~ s-^http://($ENV{'SERVER_NAME'}|$ENV{'HTTP_HOST'})--;
       my $symb=($env{'form.symb'} ne '' ? $env{'form.symb'} : (&Apache::lonnet::symbread($url)));
       if ($symb eq '') {
           if (!$silent) {
               $request->print("Unable to handle ambiguous references:$url:.");
               return ();
           }
     }      }
       &Apache::lonenc::check_decrypt(\$symb);
       return ($symb);
 }  }
   
   # --------------------------------------------------------------Get annotation
   
   sub get_annotation {
       my ($symb,$enc) = @_;
   
       my $key = $symb;
       if (!$enc) {
           $key =
               &Apache::lonnet::clutter((&Apache::lonnet::decode_symb($symb))[2]);
       }
       my %annotation=&Apache::lonnet::get('nohist_annotations',[$key]);
       return $annotation{$key};
   }
   
   sub clean_symb {
       my ($symb) = @_;
   
       &Apache::lonenc::check_decrypt(\$symb);
       my $enc = $env{'request.enc'};
       delete($env{'request.enc'});
   
       return ($symb,$enc);
   }
   
 =pod  =pod
   
Removed from v.1.651  
changed lines
  Added in v.1.692.2.4

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