--- loncom/interface/loncommon.pm 2008/03/23 21:40:10 1.648
+++ loncom/interface/loncommon.pm 2008/09/29 22:53:20 1.688
@@ -1,7 +1,7 @@
# The LearningOnline Network with CAPA
# a pile of common routines
#
-# $Id: loncommon.pm,v 1.648 2008/03/23 21:40:10 raeburn Exp $
+# $Id: loncommon.pm,v 1.688 2008/09/29 22:53:20 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -61,12 +61,15 @@ use POSIX qw(strftime mktime);
use Apache::lonmenu();
use Apache::lonenc();
use Apache::lonlocal;
+use Apache::lonnet();
use HTML::Entities;
use Apache::lonhtmlcommon();
use Apache::loncoursedata();
use Apache::lontexconvert();
use Apache::lonclonecourse();
use LONCAPA qw(:DEFAULT :match);
+use DateTime::TimeZone;
+use DateTime::Locale::Catalog;
# ---------------------------------------------- Designs
use vars qw(%defaultdesign);
@@ -133,6 +136,9 @@ sub ssi_with_retries {
do {
($content, $response) = &Apache::lonnet::ssi($resource, %form);
$ok = $response->is_success;
+ if (!$ok) {
+ &Apache::lonnet::logthis("Failed ssi_with_retries on $resource: ".$response->is_success.', '.$response->code.', '.$response->message);
+ }
$retries--;
} while (!$ok && ($retries > 0));
@@ -444,6 +450,25 @@ sub selectstudent_link {
return '';
}
+sub authorbrowser_javascript {
+ return <<"ENDAUTHORBRW";
+
+ENDAUTHORBRW
+}
+
sub coursebrowser_javascript {
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');
@@ -581,6 +606,12 @@ sub selectcourse_link {
'","'.$udomele.'","'.$desc.'","'.$extra_element.'","'.$multflag.'","'.$selecttype.'");'."'>".&mt('Select Course')."";
}
+sub selectauthor_link {
+ my ($form,$udom)=@_;
+ return ''.
+ &mt('Select Author').' ';
+}
+
sub check_uncheck_jscript {
my $jscript = <<"ENDSCRT";
function checkAll(field) {
@@ -606,6 +637,78 @@ ENDSCRT
return $jscript;
}
+sub select_timezone {
+ my ($name,$selected,$onchange,$includeempty)=@_;
+ my $output=''."\n";
+ if ($includeempty) {
+ $output .= 'all_names;
+ foreach my $tzone (@timezones) {
+ $output.= ' $tzone \n";
+ }
+ $output.=" ";
+ return $output;
+}
+
+sub select_datelocale {
+ my ($name,$selected,$onchange,$includeempty)=@_;
+ my $output=''."\n";
+ if ($includeempty) {
+ $output .= '{'id'};
+ if ($id ne '') {
+ my $en_terr = $locale->{'en_territory'};
+ my $native_terr = $locale->{'native_territory'};
+ my @languages = &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.= ' $item";
+ if ($locale_names{$item} ne '') {
+ $output.=" $locale_names{$item} \n";
+ }
+ $output.="\n";
+ }
+ $output.=" ";
+ return $output;
+}
=pod
@@ -828,7 +931,7 @@ sub help_open_topic {
# Add the graphic
my $title = &mt('Online Help');
- my $helpicon=&lonhttpdurl("/adm/help/gif/smallHelp.gif");
+ my $helpicon=&lonhttpdurl("/adm/help/help.png");
$template .= <<"ENDTEMPLATE";
ENDTEMPLATE
@@ -854,6 +957,9 @@ sub helpLatexCheatsheet {
.'
'.
&Apache::loncommon::help_open_topic("Other_Symbols",&mt('Other Symbols'),
undef,undef,600)
+ .' '.
+ &Apache::loncommon::help_open_topic("Authoring_Output_Tags",&mt('Output Tags'),
+ undef,undef,600)
.' ';
}
@@ -863,6 +969,8 @@ sub general_help {
$helptopic='Authoring_Intro';
} elsif ($env{'request.role'}=~/^cc/) {
$helptopic='Course_Coordination_Intro';
+ } elsif ($env{'request.role'}=~/^dc/) {
+ $helptopic='Domain_Coordination_Intro';
}
return $helptopic;
}
@@ -1452,9 +1560,9 @@ sub create_text_file {
$fh = Apache::File->new('>/home/httpd'.$filename);
if (! defined($fh)) {
$r->log_error("Couldn't open $filename for output $!");
- $r->print("Problems occured in creating the output file. ".
- "This error has been logged. ".
- "Please alert your LON-CAPA administrator.");
+ $r->print(&mt('Problems occurred in creating the output file. '
+ .'This error has been logged. '
+ .'Please alert your LON-CAPA administrator.'));
}
return ($fh,$filename)
}
@@ -2904,10 +3012,14 @@ sub display_languages {
sub preferred_languages {
my @languages=();
+ if (($env{'request.role.adv'}) && ($env{'form.languages'})) {
+ @languages=(@languages,split(/\s*(\,|\;|\:)\s*/,$env{'form.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'}));
@@ -2928,14 +3040,19 @@ sub preferred_languages {
}
}
}
+ return &get_genlanguages(@languages);
+}
+
+sub get_genlanguages {
+ my (@languages) = @_;
# 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]);
- }
+ unless ($lang=~/\w/) { next; }
+ push(@genlanguages,$lang);
+ if ($lang=~/(\-|\_)/) {
+ push(@genlanguages,(split(/(\-|\_)/,$lang))[0]);
+ }
}
#uniqueify the languages list
my %count;
@@ -3139,7 +3256,7 @@ sub get_student_view {
}
if (defined($target)) { $form{'grade_target'} = $target; }
$feedurl=&Apache::lonnet::clutter($feedurl);
- my $userview=&Apache::lonnet::ssi_body($feedurl,%form);
+ my ($userview,$response)=&Apache::lonnet::ssi_body($feedurl,%form);
$userview=~s/\]*\>//gi;
$userview=~s/\<\/body\>//gi;
$userview=~s/\//gi;
@@ -3148,7 +3265,39 @@ sub get_student_view {
$userview=~s/\<\/head\>//gi;
$userview=~s/action\s*\=/would_be_action\=/gi;
$userview=&relative_to_absolute($feedurl,$userview);
- return $userview;
+ if (wantarray) {
+ return ($userview,$response);
+ } else {
+ return $userview;
+ }
+}
+
+sub get_student_view_with_retries {
+ my ($symb,$retries,$username,$domain,$courseid,$target,$moreenv) = @_;
+
+ my $ok = 0; # True if we got a good response.
+ my $content;
+ my $response;
+
+ # Try to get the student_view done. within the retries count:
+
+ do {
+ ($content, $response) = &get_student_view($symb,$username,$domain,$courseid,$target,$moreenv);
+ $ok = $response->is_success;
+ if (!$ok) {
+ &Apache::lonnet::logthis("Failed get_student_view_with_retries on $symb: ".$response->is_success.', '.$response->code.', '.$response->message);
+ }
+ $retries--;
+ } while (!$ok && ($retries > 0));
+
+ if (!$ok) {
+ $content = ''; # On error return an empty content.
+ }
+ if (wantarray) {
+ return ($content, $response);
+ } else {
+ return $content;
+ }
}
=pod
@@ -3257,16 +3406,21 @@ sub pprmlink {
sub timehash {
- my @ltime=localtime(shift);
- return ( 'seconds' => $ltime[0],
- 'minutes' => $ltime[1],
- 'hours' => $ltime[2],
- 'day' => $ltime[3],
- 'month' => $ltime[4]+1,
- 'year' => $ltime[5]+1900,
- 'weekday' => $ltime[6],
- 'dayyear' => $ltime[7]+1,
- 'dlsav' => $ltime[8] );
+ my ($thistime) = @_;
+ my $timezone = &Apache::lonlocal::gettimezone();
+ my $dt = DateTime->from_epoch(epoch => $thistime)
+ ->set_time_zone($timezone);
+ my $wday = $dt->day_of_week();
+ if ($wday == 7) { $wday = 0; }
+ return ( 'second' => $dt->second(),
+ 'minute' => $dt->minute(),
+ 'hour' => $dt->hour(),
+ '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 {
@@ -3276,6 +3430,24 @@ sub utc_string {
sub maketime {
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(
($th{'seconds'},$th{'minutes'},$th{'hours'},
$th{'day'},$th{'month'}-1,$th{'year'}-1900,0,0,-1));
@@ -3656,6 +3828,60 @@ 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
=head1 Domain Template Functions
@@ -4402,7 +4628,6 @@ table.LC_docs_path td.LC_docs_path_compo
td.LC_table_cell_checkbox {
text-align: center;
}
-
table#LC_mainmenu td.LC_mainmenu_column {
vertical-align: top;
}
@@ -4416,7 +4641,7 @@ table#LC_mainmenu td.LC_mainmenu_column
.LC_menubuttons_link {
text-decoration: none;
}
-
+#2008--9-5: new menu style sheet.Changed category
.LC_menubuttons_category {
color: $font;
background: $pgbg;
@@ -4483,6 +4708,10 @@ td.LC_menubuttons_img {
text-align: right;
}
+.LC_roleslog_note {
+ font-size: smaller;
+}
+
table.LC_aboutme_port {
border: 0px;
border-collapse: collapse;
@@ -5265,6 +5494,32 @@ hr.LC_edit_problem_divide {
height: 3px;
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
}
@@ -6713,12 +6968,16 @@ sub instrule_disallow_msg {
$text{'action'} = 'IDs';
}
}
- $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.",$domdesc).' ';
+ $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.",''.$domdesc.' ').' ';
if ($mode eq 'upload') {
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'}.");
} 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 {
if ($checkitem eq 'username') {
@@ -6748,7 +7007,7 @@ sub sorted_inst_types {
my ($usertypes,$order) = &Apache::lonnet::retrieve_inst_usertypes($dom);
my $othertitle = &mt('All users');
if ($env{'request.course.id'}) {
- $othertitle = 'any';
+ $othertitle = &mt('Any users');
}
my @types;
if (ref($order) eq 'ARRAY') {
@@ -6761,9 +7020,6 @@ sub sorted_inst_types {
}
if (keys(%{$usertypes}) > 0) {
$othertitle = &mt('Other users');
- if ($env{'request.course.id'}) {
- $othertitle = 'other';
- }
}
return ($othertitle,$usertypes,\@types);
}
@@ -6949,6 +7205,232 @@ sub get_env_multiple {
return(@values);
}
+sub ask_for_embedded_content {
+ my ($actionurl,$state,$allfiles,$codebase,$args)=@_;
+ my $upload_output = '
+ ';
+ 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 .= ''
+ .&mt('An error occurred ([_1]) while trying to upload [_2] for embedded element [_3].'
+ ,$result,$orig_uploaded_filename,$env{'form.embedded_orig_'.$i})
+ .' ';
+ next;
+ } else {
+ $output .= ''.&mt('Uploaded [_1]',''.
+ $path.$fname.' ').'
';
+ }
+ } 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 .= ''.
+ &mt('An error occurred while trying to upload [_1] for embedded element [_2].',$orig_uploaded_filename,$env{'form.embedded_orig_'.$i}).
+ ' ';
+ } else {
+ if (!print $fh $env{'form.embedded_item_'.$i}) {
+ &Apache::lonnet::logthis('Failed to write to '.$dest);
+ $output .= ''.
+ &mt('An error occurred while writing the file [_1] for embedded element [_2].',$orig_uploaded_filename,$env{'form.embedded_orig_'.$i}).
+ ' ';
+ } else {
+ if ($context eq 'testbank') {
+ $output .= &mt('Embedded file uploaded successfully:').
+ ' '.
+ $orig_uploaded_filename.' ';
+ } else {
+ $output .= ''.
+ &mt('View embedded file: [_1]',''.
+ $orig_uploaded_filename.' ').' ';
+ }
+ }
+ 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].',''.$fname.' ',$path);
+ } elsif (-e $path.'/'.$fname) {
+ $state = 'exists';
+ $msg = &mt('Unable to upload [_1]. A file by that name was found in [_2].',''.$fname.' ',$path);
+ }
+ if ($state eq 'exists') {
+ $msg = ''.$msg.' ';
+ }
+ 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 = ''.
+ &mt('Unable to upload [_1]. (size = [_2] kilobytes). Disk quota will be exceeded.',''.$fname.' ',$filesize).' '.
+ ' '.&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 = '';
+ $msg .= &mt('Unable to upload [_1]. A locked file by that name was found in [_2].',''.$fname.' ',''.$port_path.$env{'form.currentpath'}.' ');
+ $msg .= ' ';
+ $msg .= &mt('You will be able to rename or delete existing [_1] after a grade has been assigned.',''.$fname.' ');
+ return ('file_locked',$msg);
+ } else {
+ my $msg = '';
+ $msg .= &mt('Unable to upload [_1]. A file by that name was found in [_2].',''.$fname.' ',$port_path.$env{'form.currentpath'});
+ $msg .= ' ';
+ $msg .= ' ';
+ $msg .= &mt('To upload, rename or delete existing [_1] in [_2].',''.$fname.' ', $port_path.$env{'form.currentpath'});
+ return ('file_exists',$msg);
+ }
+ }
+}
+
=pod
@@ -7178,7 +7660,7 @@ Apache Request ref, $records is an array
######################################################
sub csv_print_samples {
my ($r,$records) = @_;
- my $samples = &get_samples($records,3);
+ my $samples = &get_samples($records,5);
$r->print(&mt('Samples').' '.&start_data_table().
&start_data_table_header_row());
@@ -7233,7 +7715,7 @@ sub csv_print_select_table {
foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
$r->print('Column '.($sample+1).' ');
+ '>'.&mt('Column [_1]',($sample+1)).'');
}
$r->print(''.&end_data_table_row()."\n");
$i++;
@@ -7264,7 +7746,8 @@ sub csv_samples_select_table {
my ($r,$records,$d) = @_;
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().
&start_data_table_header_row().''.
&mt('Field').' '.&mt('Samples').' '.
@@ -7280,7 +7763,7 @@ sub csv_samples_select_table {
$display.'');
}
$r->print('');
- foreach my $line (0..2) {
+ foreach my $line (0..($max_samples-1)) {
if (defined($samples->[$line]{$key})) {
$r->print($samples->[$line]{$key}." \n");
}
@@ -7891,7 +8374,9 @@ defdom (domain for which to retrieve con
origmail (scalar - email address of recipient from loncapa.conf,
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
@@ -7919,8 +8404,10 @@ sub build_recipient_list {
} elsif ($origmail ne '') {
push(@recipients,$origmail);
}
- if ($defmail ne '') {
- push(@recipients,$defmail);
+ if (defined($defmail)) {
+ if ($defmail ne '') {
+ push(@recipients,$defmail);
+ }
}
if ($otheremails) {
my @others;
@@ -7942,13 +8429,347 @@ 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(' -> ',(@{$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(' -> ',(@{$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 .= ' '.
+ ' '.$parent.' '.
+ ' ';
+ my $depth = 1;
+ push(@path,$parent);
+ $output .= &assign_category_rows($itemcount,\@cats,$depth,$parent,\@path,\@currcategories);
+ pop(@path);
+ $output .= ' ';
+ $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 .= ' ';
+ }
+ }
+ }
+ return $text;
+}
+
+############################################################
+############################################################
+
+
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.
($start?', '.&mt('starting').' '.localtime($start):'').
($end?', ending '.localtime($end):'').': '.
&Apache::lonnet::assigncustomrole(
- $udom,$uname,$url,$three,$four,$five,$end,$start).
+ $udom,$uname,$url,$three,$four,$five,$end,$start,undef,undef,$context).
' ';
return $output;
}
@@ -7983,7 +8804,7 @@ sub commit_standardrole {
$output = &mt('Assigning').' '.$three.' in '.$url.
($start?', '.&mt('starting').' '.localtime($start):'').
($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') {
$output .= $result.$linefeed;
} else {
@@ -8018,7 +8839,7 @@ sub commit_studentrole {
}
$oldsecurl = $uurl;
$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 ($expire_role_result eq 'refused') {
my @roles = ('st');
@@ -8041,7 +8862,7 @@ sub commit_studentrole {
}
}
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 ($secchange == 1) {
if ($sec eq '') {
@@ -8606,7 +9427,7 @@ sub init_user_environment {
}
# Give them a new cookie
my $id = ($args->{'robot'} ? 'robot'.$args->{'robot'}
- : $now);
+ : $now.$$.int(rand(10000)));
$cookie="$username\_$id\_$domain\_$authhost";
# Initialize roles
@@ -8721,12 +9542,52 @@ sub init_user_environment {
sub _add_to_env {
my ($idf,$env_data,$prefix) = @_;
- while (my ($key,$value) = each(%$env_data)) {
- $idf->{$prefix.$key} = $value;
- $env{$prefix.$key} = $value;
+ if (ref($env_data) eq 'HASH') {
+ while (my ($key,$value) = each(%$env_data)) {
+ $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