'.
- &mt('Field').' '.&mt('Samples').' ');
- %sone=&record_sep($$records[0]);
- if (defined($$records[1])) {%stwo=&record_sep($$records[1]);}
- if (defined($$records[2])) {%sthree=&record_sep($$records[2]);}
- #
- foreach (sort keys %sone) {
- $r->print('print(&start_data_table().
+ &start_data_table_header_row().''.
+ &mt('Field').' '.&mt('Samples').' '.
+ &end_data_table_header_row());
+
+ foreach my $key (sort(keys(%{ $samples->[0] }))) {
+ $r->print(&start_data_table_row().'');
- foreach (@$d) {
- my ($value,$display)=@{ $_ };
- $r->print(''.$display.' ');
+ foreach my $option (@$d) {
+ my ($value,$display,$defaultcol)=@{ $option };
+ $r->print(''.
+ $display.' ');
}
$r->print(' ');
- if (defined($sone{$_})) { $r->print($sone{$_}."\n"); }
- if (defined($stwo{$_})) { $r->print($stwo{$_}."\n"); }
- if (defined($sthree{$_})) { $r->print($sthree{$_}."\n"); }
- $r->print(' ');
+ foreach my $line (0..($max_samples-1)) {
+ if (defined($samples->[$line]{$key})) {
+ $r->print($samples->[$line]{$key}." \n");
+ }
+ }
+ $r->print(''.&end_data_table_row());
$i++;
}
+ $r->print(&end_data_table());
$i--;
return($i);
}
@@ -2877,7 +8200,7 @@ sub csv_samples_select_table {
=pod
-=item clean_excel_name($name)
+=item * &clean_excel_name($name)
Returns a replacement for $name which does not contain any illegal characters.
@@ -2896,7 +8219,7 @@ sub clean_excel_name {
=pod
-=item * check_if_partid_hidden($id,$symb,$udom,$uname)
+=item * &check_if_partid_hidden($id,$symb,$udom,$uname)
Returns either 1 or undef
@@ -2937,7 +8260,7 @@ sub check_if_partid_hidden {
=over 4
-=item get_cgi_id
+=item * &get_cgi_id()
Inputs: none
@@ -2953,7 +8276,7 @@ the routine &Apache::lonnet::transfer_pr
my $uniq=0;
sub get_cgi_id {
$uniq=($uniq+1)%100000;
- return (time.'_'.$uniq);
+ return (time.'_'.$$.'_'.$uniq);
}
############################################################
@@ -2961,7 +8284,7 @@ sub get_cgi_id {
=pod
-=item DrawBarGraph
+=item * &DrawBarGraph()
Facilitates the plotting of data in a (stacked) bar graph.
Puts plot definition data into the users environment in order for
@@ -2984,9 +8307,14 @@ If $Max is < any data point, the graph w
=item $colors: array ref holding the colors to be used for the data sets when
they are plotted. If undefined, default values will be used.
+=item $labels: array ref holding the labels to use on the x-axis for the bars.
+
=item @Values: An array of array references. Each array reference holds data
to be plotted in a stacked bar chart.
+=item If the final element of @Values is a hash reference the key/value
+pairs will be added to the graph definition.
+
=back
Returns:
@@ -2999,7 +8327,7 @@ information for the plot.
############################################################
############################################################
sub DrawBarGraph {
- my ($Title,$xlabel,$ylabel,$Max,$colors,@Values)=@_;
+ my ($Title,$xlabel,$ylabel,$Max,$colors,$labels,@Values)=@_;
#
if (! defined($colors)) {
$colors = ['#33ff00',
@@ -3007,13 +8335,28 @@ sub DrawBarGraph {
'#66ccff', '#ff9999', '#cccc33', '#660000', '#33cc66',
];
}
+ my $extra_settings = {};
+ if (ref($Values[-1]) eq 'HASH') {
+ $extra_settings = pop(@Values);
+ }
#
my $identifier = &get_cgi_id();
my $id = 'cgi.'.$identifier;
if (! @Values || ref($Values[0]) ne 'ARRAY') {
return '';
}
+ #
+ my @Labels;
+ if (defined($labels)) {
+ @Labels = @$labels;
+ } else {
+ for (my $i=0;$i<@{$Values[0]};$i++) {
+ push (@Labels,$i+1);
+ }
+ }
+ #
my $NumBars = scalar(@{$Values[0]});
+ if ($NumBars < scalar(@Labels)) { $NumBars = scalar(@Labels); }
my %ValuesHash;
my $NumSets=1;
foreach my $array (@Values) {
@@ -3023,7 +8366,15 @@ sub DrawBarGraph {
}
#
my ($height,$width,$xskip,$bar_width) = (200,120,1,15);
- if ($NumBars < 10) {
+ if ($NumBars < 3) {
+ $width = 120+$NumBars*32;
+ $xskip = 1;
+ $bar_width = 30;
+ } elsif ($NumBars < 5) {
+ $width = 120+$NumBars*20;
+ $xskip = 1;
+ $bar_width = 20;
+ } elsif ($NumBars < 10) {
$width = 120+$NumBars*15;
$xskip = 1;
$bar_width = 15;
@@ -3041,11 +8392,6 @@ sub DrawBarGraph {
$bar_width = 4;
}
#
- my @Labels;
- for (my $i=0;$i<@{$Values[0]};$i++) {
- push (@Labels,$i+1);
- }
- #
$Max = 1 if ($Max < 1);
if ( int($Max) < $Max ) {
$Max++;
@@ -3054,9 +8400,9 @@ sub DrawBarGraph {
$Title = '' if (! defined($Title));
$xlabel = '' if (! defined($xlabel));
$ylabel = '' if (! defined($ylabel));
- $ValuesHash{$id.'.title'} = &Apache::lonnet::escape($Title);
- $ValuesHash{$id.'.xlabel'} = &Apache::lonnet::escape($xlabel);
- $ValuesHash{$id.'.ylabel'} = &Apache::lonnet::escape($ylabel);
+ $ValuesHash{$id.'.title'} = &escape($Title);
+ $ValuesHash{$id.'.xlabel'} = &escape($xlabel);
+ $ValuesHash{$id.'.ylabel'} = &escape($ylabel);
$ValuesHash{$id.'.y_max_value'} = $Max;
$ValuesHash{$id.'.NumBars'} = $NumBars;
$ValuesHash{$id.'.NumSets'} = $NumSets;
@@ -3068,7 +8414,12 @@ sub DrawBarGraph {
$ValuesHash{$id.'.bar_width'} = $bar_width;
$ValuesHash{$id.'.labels'} = join(',',@Labels);
#
- &Apache::lonnet::appenv(%ValuesHash);
+ # Deal with other parameters
+ while (my ($key,$value) = each(%$extra_settings)) {
+ $ValuesHash{$id.'.'.$key} = $value;
+ }
+ #
+ &Apache::lonnet::appenv(\%ValuesHash);
return ' ';
}
@@ -3077,7 +8428,7 @@ sub DrawBarGraph {
=pod
-=item DrawXYGraph
+=item * &DrawXYGraph()
Facilitates the plotting of data in an XY graph.
Puts plot definition data into the users environment in order for
@@ -3102,7 +8453,7 @@ plotted in. If undefined, default value
=item $Xlabels: Array ref containing the labels to be used for the X-axis.
=item $Ydata: Array ref containing Array refs.
-Each of the contained arrays will be plotted as a seperate curve.
+Each of the contained arrays will be plotted as a separate curve.
=item %Values: hash indicating or overriding any default values which are
passed to graph.png.
@@ -3131,9 +8482,9 @@ sub DrawXYGraph {
$ylabel = '' if (! defined($ylabel));
my %ValuesHash =
(
- $id.'.title' => &Apache::lonnet::escape($Title),
- $id.'.xlabel' => &Apache::lonnet::escape($xlabel),
- $id.'.ylabel' => &Apache::lonnet::escape($ylabel),
+ $id.'.title' => &escape($Title),
+ $id.'.xlabel' => &escape($xlabel),
+ $id.'.ylabel' => &escape($ylabel),
$id.'.y_max_value'=> $Max,
$id.'.labels' => join(',',@$Xlabels),
$id.'.PlotType' => 'XY',
@@ -3158,7 +8509,7 @@ sub DrawXYGraph {
$ValuesHash{$id.'.'.$key} = $value;
}
#
- &Apache::lonnet::appenv(%ValuesHash);
+ &Apache::lonnet::appenv(\%ValuesHash);
return ' ';
}
@@ -3167,7 +8518,7 @@ sub DrawXYGraph {
=pod
-=item DrawXYYGraph
+=item * &DrawXYYGraph()
Facilitates the plotting of data in an XY graph with two Y axes.
Puts plot definition data into the users environment in order for
@@ -3228,9 +8579,9 @@ sub DrawXYYGraph {
$ylabel = '' if (! defined($ylabel));
my %ValuesHash =
(
- $id.'.title' => &Apache::lonnet::escape($Title),
- $id.'.xlabel' => &Apache::lonnet::escape($xlabel),
- $id.'.ylabel' => &Apache::lonnet::escape($ylabel),
+ $id.'.title' => &escape($Title),
+ $id.'.xlabel' => &escape($xlabel),
+ $id.'.ylabel' => &escape($ylabel),
$id.'.labels' => join(',',@$Xlabels),
$id.'.PlotType' => 'XY',
$id.'.NumSets' => 2,
@@ -3260,7 +8611,7 @@ sub DrawXYYGraph {
$ValuesHash{$id.'.'.$key} = $value;
}
#
- &Apache::lonnet::appenv(%ValuesHash);
+ &Apache::lonnet::appenv(\%ValuesHash);
return ' ';
}
@@ -3277,7 +8628,7 @@ Bad place for them but what the hell.
=over 4
-=item &chartlink
+=item * &chartlink()
Returns a link to the chart for a specific student.
@@ -3302,8 +8653,8 @@ Inputs:
sub chartlink {
my ($linktext, $sname, $sdomain) = @_;
my $link = ''.$linktext.' ';
}
@@ -3316,9 +8667,9 @@ sub chartlink {
=over 4
-=item &restore_course_settings
+=item * &restore_course_settings()
-=item &store_course_settings
+=item * &store_course_settings()
Restores/Store indicated form parameters from the course environment.
Will not overwrite existing values of the form parameters.
@@ -3332,46 +8683,53 @@ a hash ref describing the data to be sto
'chartoutputmode' => 'scalar',
'chartoutputdata' => 'scalar',
'Section' => 'array',
+ 'Group' => 'array',
'StudentData' => 'array',
'Maps' => 'array');
Returns: both routines return nothing
+=back
+
=cut
#######################################################
#######################################################
sub store_course_settings {
+ return &store_settings($env{'request.course.id'},@_);
+}
+
+sub store_settings {
# save to the environment
# appenv the same items, just to be safe
- my $courseid = $ENV{'request.course.id'};
- my $coursedom = $ENV{'course.'.$courseid.'.domain'};
- my ($prefix,$Settings) = @_;
+ my $udom = $env{'user.domain'};
+ my $uname = $env{'user.name'};
+ my ($context,$prefix,$Settings) = @_;
my %SaveHash;
my %AppHash;
while (my ($setting,$type) = each(%$Settings)) {
- my $basename = 'env.internal.'.$prefix.'.'.$setting;
- my $envname = 'course.'.$courseid.'.'.$basename;
- if (exists($ENV{'form.'.$setting})) {
+ my $basename = join('.','internal',$context,$prefix,$setting);
+ my $envname = 'environment.'.$basename;
+ if (exists($env{'form.'.$setting})) {
# Save this value away
if ($type eq 'scalar' &&
- (! exists($ENV{$envname}) ||
- $ENV{$envname} ne $ENV{'form.'.$setting})) {
- $SaveHash{$basename} = $ENV{'form.'.$setting};
- $AppHash{$envname} = $ENV{'form.'.$setting};
+ (! exists($env{$envname}) ||
+ $env{$envname} ne $env{'form.'.$setting})) {
+ $SaveHash{$basename} = $env{'form.'.$setting};
+ $AppHash{$envname} = $env{'form.'.$setting};
} elsif ($type eq 'array') {
my $stored_form;
- if (ref($ENV{'form.'.$setting})) {
+ if (ref($env{'form.'.$setting})) {
$stored_form = join(',',
map {
- &Apache::lonnet::escape($_);
- } sort(@{$ENV{'form.'.$setting}}));
+ &escape($_);
+ } sort(@{$env{'form.'.$setting}}));
} else {
$stored_form =
- &Apache::lonnet::escape($ENV{'form.'.$setting});
+ &escape($env{'form.'.$setting});
}
# Determine if the array contents are the same.
- if ($stored_form ne $ENV{$envname}) {
+ if ($stored_form ne $env{$envname}) {
$SaveHash{$basename} = $stored_form;
$AppHash{$envname} = $stored_form;
}
@@ -3379,54 +8737,1005 @@ sub store_course_settings {
}
}
my $put_result = &Apache::lonnet::put('environment',\%SaveHash,
- $coursedom,
- $ENV{'course.'.$courseid.'.num'});
+ $udom,$uname);
if ($put_result !~ /^(ok|delayed)/) {
&Apache::lonnet::logthis('unable to save form parameters, '.
'got error:'.$put_result);
}
# Make sure these settings stick around in this session, too
- &Apache::lonnet::appenv(%AppHash);
+ &Apache::lonnet::appenv(\%AppHash);
return;
}
sub restore_course_settings {
- my $courseid = $ENV{'request.course.id'};
- my ($prefix,$Settings) = @_;
+ return &restore_settings($env{'request.course.id'},@_);
+}
+
+sub restore_settings {
+ my ($context,$prefix,$Settings) = @_;
while (my ($setting,$type) = each(%$Settings)) {
- next if (exists($ENV{'form.'.$setting}));
- my $envname = 'course.'.$courseid.'.env.internal.'.$prefix.
+ next if (exists($env{'form.'.$setting}));
+ my $envname = 'environment.internal.'.$context.'.'.$prefix.
'.'.$setting;
- if (exists($ENV{$envname})) {
+ if (exists($env{$envname})) {
if ($type eq 'scalar') {
- $ENV{'form.'.$setting} = $ENV{$envname};
+ $env{'form.'.$setting} = $env{$envname};
} elsif ($type eq 'array') {
- $ENV{'form.'.$setting} = [
+ $env{'form.'.$setting} = [
map {
- &Apache::lonnet::unescape($_);
- } split(',',$ENV{$envname})
+ &unescape($_);
+ } split(',',$env{$envname})
];
}
}
}
}
+#######################################################
+#######################################################
+
+=pod
+
+=head1 Domain E-mail Routines
+
+=over 4
+
+=item * &build_recipient_list()
+
+Build recipient lists for three types of e-mail:
+(a) Error Reports, (b) Package Updates, (c) Help requests, generated by
+lonerrorhandler.pm, CHECKRPMS and lonsupportreq.pm respectively.
+
+Inputs:
+defmail (scalar - email address of default recipient),
+mailing type (scalar - errormail, packagesmail, or helpdeskmail),
+defdom (domain for which to retrieve configuration settings),
+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.
+
+=back
+
+=cut
+
############################################################
############################################################
+sub build_recipient_list {
+ my ($defmail,$mailing,$defdom,$origmail) = @_;
+ my @recipients;
+ my $otheremails;
+ my %domconfig =
+ &Apache::lonnet::get_dom('configuration',['contacts'],$defdom);
+ if (ref($domconfig{'contacts'}) eq 'HASH') {
+ if (ref($domconfig{'contacts'}{$mailing}) eq 'HASH') {
+ my @contacts = ('adminemail','supportemail');
+ foreach my $item (@contacts) {
+ if ($domconfig{'contacts'}{$mailing}{$item}) {
+ my $addr = $domconfig{'contacts'}{$item};
+ if (!grep(/^\Q$addr\E$/,@recipients)) {
+ push(@recipients,$addr);
+ }
+ }
+ $otheremails = $domconfig{'contacts'}{$mailing}{'others'};
+ }
+ }
+ } elsif ($origmail ne '') {
+ push(@recipients,$origmail);
+ }
+ if (defined($defmail)) {
+ if ($defmail ne '') {
+ push(@recipients,$defmail);
+ }
+ }
+ if ($otheremails) {
+ my @others;
+ if ($otheremails =~ /,/) {
+ @others = split(/,/,$otheremails);
+ } else {
+ push(@others,$otheremails);
+ }
+ foreach my $addr (@others) {
+ if (!grep(/^\Q$addr\E$/,@recipients)) {
+ push(@recipients,$addr);
+ }
+ }
+ }
+ my $recipientlist = join(',',@recipients);
+ return $recipientlist;
+}
-sub propath {
- my ($udom,$uname)=@_;
- $udom=~s/\W//g;
- $uname=~s/\W//g;
- my $subdir=$uname.'__';
- $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
- my $proname="$Apache::lonnet::perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
- return $proname;
-}
+############################################################
+############################################################
+
+=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,$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,undef,undef,$context).
+ ' ';
+ return $output;
+}
+
+sub commit_standardrole {
+ my ($udom,$uname,$url,$three,$start,$end,$one,$two,$sec,$context) = @_;
+ my ($output,$logmsg,$linefeed);
+ if ($context eq 'auto') {
+ $linefeed = "\n";
+ } else {
+ $linefeed = " \n";
+ }
+ if ($three eq 'st') {
+ my $result = &commit_studentrole(\$logmsg,$udom,$uname,$url,$three,$start,$end,
+ $one,$two,$sec,$context);
+ if (($result =~ /^error/) || ($result eq 'not_in_class') ||
+ ($result eq 'unknown_course') || ($result eq 'refused')) {
+ $output = $logmsg.' '.&mt('Error: ').$result."\n";
+ } else {
+ $output = $logmsg.$linefeed.&mt('Assigning').' '.$three.' in '.$url.
+ ($start?', '.&mt('starting').' '.localtime($start):'').
+ ($end?', '.&mt('ending').' '.localtime($end):'').': ';
+ if ($context eq 'auto') {
+ $output .= $result.$linefeed.&mt('Add to classlist').': ok';
+ } else {
+ $output .= ''.$result.' '.$linefeed.
+ &mt('Add to classlist').': ok ';
+ }
+ $output .= $linefeed;
+ }
+ } else {
+ $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,'','',$context);
+ if ($context eq 'auto') {
+ $output .= $result.$linefeed;
+ } else {
+ $output .= ''.$result.' '.$linefeed;
+ }
+ }
+ return $output;
+}
+
+sub commit_studentrole {
+ my ($logmsg,$udom,$uname,$url,$three,$start,$end,$one,$two,$sec,$context) = @_;
+ my ($result,$linefeed,$oldsecurl,$newsecurl);
+ if ($context eq 'auto') {
+ $linefeed = "\n";
+ } else {
+ $linefeed = ' '."\n";
+ }
+ if (defined($one) && defined($two)) {
+ my $cid=$one.'_'.$two;
+ my $oldsec=&Apache::lonnet::getsection($udom,$uname,$cid);
+ my $secchange = 0;
+ my $expire_role_result;
+ my $modify_section_result;
+ if ($oldsec ne '-1') {
+ if ($oldsec ne $sec) {
+ $secchange = 1;
+ my $now = time;
+ my $uurl='/'.$cid;
+ $uurl=~s/\_/\//g;
+ if ($oldsec) {
+ $uurl.='/'.$oldsec;
+ }
+ $oldsecurl = $uurl;
+ $expire_role_result =
+ &Apache::lonnet::assignrole($udom,$uname,$uurl,'st',$now,'','',$context);
+ if ($env{'request.course.sec'} ne '') {
+ if ($expire_role_result eq 'refused') {
+ my @roles = ('st');
+ my @statuses = ('previous');
+ my @roledoms = ($one);
+ my $withsec = 1;
+ my %roleshash =
+ &Apache::lonnet::get_my_roles($uname,$udom,'userroles',
+ \@statuses,\@roles,\@roledoms,$withsec);
+ if (defined ($roleshash{$two.':'.$one.':st:'.$oldsec})) {
+ my ($oldstart,$oldend) =
+ split(':',$roleshash{$two.':'.$one.':st:'.$oldsec});
+ if ($oldend > 0 && $oldend <= $now) {
+ $expire_role_result = 'ok';
+ }
+ }
+ }
+ }
+ $result = $expire_role_result;
+ }
+ }
+ 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,'',$context);
+ if ($modify_section_result =~ /^ok/) {
+ if ($secchange == 1) {
+ if ($sec eq '') {
+ $$logmsg .= &mt('Section for [_1] switched from (possibly expired) old section: [_2] to student role without a section.',$uname,$oldsec).$linefeed;
+ } else {
+ $$logmsg .= &mt('Section for [_1] switched from (possibly expired) old section: [_2] to new section: [_3].',$uname,$oldsec,$sec).$linefeed;
+ }
+ } elsif ($oldsec eq '-1') {
+ if ($sec eq '') {
+ $$logmsg .= &mt('New student role without a section for [_1] in course [_2].',$uname,$cid).$linefeed;
+ } else {
+ $$logmsg .= &mt('New student role for [_1] in section [_2] in course [_3].',$uname,$sec,$cid).$linefeed;
+ }
+ } else {
+ if ($sec eq '') {
+ $$logmsg .= &mt('Student [_1] assigned to course [_2] without a section.',$uname,$cid).$linefeed;
+ } else {
+ $$logmsg .= &mt('Student [_1] assigned to section [_2] in course [_3].',$uname,$sec,$cid).$linefeed;
+ }
+ }
+ } else {
+ if ($secchange) {
+ $$logmsg .= &mt('Error when attempting section change for [_1] from old section "[_2]" to new section: "[_3]" in course [_4] -error:',$uname,$oldsec,$sec,$cid).' '.$modify_section_result.$linefeed;
+ } else {
+ $$logmsg .= &mt('Error when attempting to modify role for [_1] for section: "[_2]" in course [_3] -error:',$uname,$sec,$cid).' '.$modify_section_result.$linefeed;
+ }
+ }
+ $result = $modify_section_result;
+ } elsif ($secchange == 1) {
+ if ($oldsec eq '') {
+ $$logmsg .= &mt('Error when attempting to expire existing role without a section for [_1] in course [_3] -error: ',$uname,$cid).' '.$expire_role_result.$linefeed;
+ } else {
+ $$logmsg .= &mt('Error when attempting to expire existing role for [_1] in section [_2] in course [_3] -error: ',$uname,$oldsec,$cid).' '.$expire_role_result.$linefeed;
+ }
+ if ($expire_role_result eq 'refused') {
+ my $newsecurl = '/'.$cid;
+ $newsecurl =~ s/\_/\//g;
+ if ($sec ne '') {
+ $newsecurl.='/'.$sec;
+ }
+ if (&Apache::lonnet::allowed('cst',$newsecurl) && !(&Apache::lonnet::allowed('cst',$oldsecurl))) {
+ if ($sec eq '') {
+ $$logmsg .= &mt('Although your current role has privileges to add students to section "[_1]", you do not have privileges to modify existing enrollments unaffiliated with any section.',$sec).$linefeed;
+ } else {
+ $$logmsg .= &mt('Although your current role has privileges to add students to section "[_1]", you do not have privileges to modify existing enrollments in other sections.',$sec).$linefeed;
+ }
+ }
+ }
+ }
+ } else {
+ $$logmsg .= &mt('Incomplete course id defined.').$linefeed.&mt('Addition of user [_1] from domain [_2] to course [_3], section [_4] not completed.',$uname,$udom,$one.'_'.$two,$sec).$linefeed;
+ $result = "error: incomplete course id\n";
+ }
+ return $result;
+}
+
+############################################################
+############################################################
+
+sub check_clone {
+ my ($args,$linefeed) = @_;
+ my $cloneid='/'.$args->{'clonedomain'}.'/'.$args->{'clonecourse'};
+ my ($clonecrsudom,$clonecrsunum)= &LONCAPA::split_courseid($cloneid);
+ my $clonehome=&Apache::lonnet::homeserver($clonecrsunum,$clonecrsudom);
+ my $clonemsg;
+ my $can_clone = 0;
+
+ if ($clonehome eq 'no_host') {
+ $clonemsg = &mt('No new course created.').$linefeed.&mt('A new course could not be cloned from the specified original - [_1] - because it is a non-existent course.',$args->{'clonecourse'}.':'.$args->{'clonedomain'});
+ } else {
+ my %clonedesc = &Apache::lonnet::coursedescription($cloneid,{'one_time' => 1});
+ if ($env{'request.role.domain'} eq $args->{'clonedomain'}) {
+ $can_clone = 1;
+ } else {
+ my %clonehash = &Apache::lonnet::get('environment',['cloners'],
+ $args->{'clonedomain'},$args->{'clonecourse'});
+ my @cloners = split(/,/,$clonehash{'cloners'});
+ if (grep(/^\*$/,@cloners)) {
+ $can_clone = 1;
+ } elsif (grep(/^\*\:\Q$args->{'ccdomain'}\E$/,@cloners)) {
+ $can_clone = 1;
+ } else {
+ my %roleshash =
+ &Apache::lonnet::get_my_roles($args->{'ccuname'},
+ $args->{'ccdomain'},
+ 'userroles',['active'],['cc'],
+ [$args->{'clonedomain'}]);
+ if (($roleshash{$args->{'clonecourse'}.':'.$args->{'clonedomain'}.':cc'}) || (grep(/^\Q$args->{'ccuname'}\E:\Q$args->{'ccdomain'}\E$/,@cloners))) {
+ $can_clone = 1;
+ } else {
+ $clonemsg = &mt('No new course created.').$linefeed.&mt('The new course could not be cloned from the existing course because the new course owner ([_1]) does not have cloning rights in the existing course ([_2]).',$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'});
+ }
+ }
+ }
+ }
+ return ($can_clone, $clonemsg, $cloneid, $clonehome);
+}
+
+sub construct_course {
+ my ($args,$logmsg,$courseid,$crsudom,$crsunum,$udom,$uname,$context) = @_;
+ my $outcome;
+ my $linefeed = ' '."\n";
+ if ($context eq 'auto') {
+ $linefeed = "\n";
+ }
+
+#
+# Are we cloning?
+#
+ my ($can_clone, $clonemsg, $cloneid, $clonehome);
+ if (($args->{'clonecourse'}) && ($args->{'clonedomain'})) {
+ ($can_clone, $clonemsg, $cloneid, $clonehome) = &check_clone($args,$linefeed);
+ if ($context ne 'auto') {
+ if ($clonemsg ne '') {
+ $clonemsg = ''.$clonemsg.' ';
+ }
+ }
+ $outcome .= $clonemsg.$linefeed;
+
+ if (!$can_clone) {
+ return (0,$outcome);
+ }
+ }
+
+#
+# Open course
+#
+ my $crstype = lc($args->{'crstype'});
+ my %cenv=();
+ $$courseid=&Apache::lonnet::createcourse($args->{'course_domain'},
+ $args->{'cdescr'},
+ $args->{'curl'},
+ $args->{'course_home'},
+ $args->{'nonstandard'},
+ $args->{'crscode'},
+ $args->{'ccuname'}.':'.
+ $args->{'ccdomain'},
+ $args->{'crstype'});
+
+ # Note: The testing routines depend on this being output; see
+ # Utils::Course. This needs to at least be output as a comment
+ # if anyone ever decides to not show this, and Utils::Course::new
+ # will need to be suitably modified.
+ $outcome .= &mt('New LON-CAPA [_1] ID: [_2]',$crstype,$$courseid).$linefeed;
+#
+# Check if created correctly
+#
+ ($$crsudom,$$crsunum)= &LONCAPA::split_courseid($$courseid);
+ my $crsuhome=&Apache::lonnet::homeserver($$crsunum,$$crsudom);
+ $outcome .= &mt('Created on').': '.$crsuhome.$linefeed;
+
+#
+# Do the cloning
+#
+ if ($can_clone && $cloneid) {
+ $clonemsg = &mt('Cloning [_1] from [_2]',$crstype,$clonehome);
+ if ($context ne 'auto') {
+ $clonemsg = ''.$clonemsg.' ';
+ }
+ $outcome .= $clonemsg.$linefeed;
+ my %oldcenv=&Apache::lonnet::dump('environment',$$crsudom,$$crsunum);
+# Copy all files
+ &Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid,$args->{'datemode'},$args->{'dateshift'});
+# Restore URL
+ $cenv{'url'}=$oldcenv{'url'};
+# Restore title
+ $cenv{'description'}=$oldcenv{'description'};
+# Mark as cloned
+ $cenv{'clonedfrom'}=$cloneid;
+# Need to clone grading mode
+ my %newenv=&Apache::lonnet::get('environment',['grading'],$$crsudom,$$crsunum);
+ $cenv{'grading'}=$newenv{'grading'};
+# Do not clone these environment entries
+ &Apache::lonnet::del('environment',
+ ['default_enrollment_start_date',
+ 'default_enrollment_end_date',
+ 'question.email',
+ 'policy.email',
+ 'comment.email',
+ 'pch.users.denied',
+ 'plc.users.denied',
+ 'hidefromcat',
+ 'categories'],
+ $$crsudom,$$crsunum);
+ }
+
+#
+# Set environment (will override cloned, if existing)
+#
+ my @sections = ();
+ my @xlists = ();
+ if ($args->{'crstype'}) {
+ $cenv{'type'}=$args->{'crstype'};
+ }
+ if ($args->{'crsid'}) {
+ $cenv{'courseid'}=$args->{'crsid'};
+ }
+ if ($args->{'crscode'}) {
+ $cenv{'internal.coursecode'}=$args->{'crscode'};
+ }
+ if ($args->{'crsquota'} ne '') {
+ $cenv{'internal.coursequota'}=$args->{'crsquota'};
+ } else {
+ $cenv{'internal.coursequota'}=$args->{'crsquota'} = 20;
+ }
+ if ($args->{'ccuname'}) {
+ $cenv{'internal.courseowner'} = $args->{'ccuname'}.
+ ':'.$args->{'ccdomain'};
+ } else {
+ $cenv{'internal.courseowner'} = $args->{'curruser'};
+ }
+ my @badclasses = (); # Used to accumulate sections/crosslistings that did not pass classlist access check for course owner.
+ if ($args->{'crssections'}) {
+ $cenv{'internal.sectionnums'} = '';
+ if ($args->{'crssections'} =~ m/,/) {
+ @sections = split/,/,$args->{'crssections'};
+ } else {
+ $sections[0] = $args->{'crssections'};
+ }
+ if (@sections > 0) {
+ foreach my $item (@sections) {
+ my ($sec,$gp) = split/:/,$item;
+ my $class = $args->{'crscode'}.$sec;
+ my $addcheck = &Apache::lonnet::auto_new_course($$crsunum,$$crsudom,$class,$cenv{'internal.courseowner'});
+ $cenv{'internal.sectionnums'} .= $item.',';
+ unless ($addcheck eq 'ok') {
+ push @badclasses, $class;
+ }
+ }
+ $cenv{'internal.sectionnums'} =~ s/,$//;
+ }
+ }
+# do not hide course coordinator from staff listing,
+# even if privileged
+ $cenv{'nothideprivileged'}=$args->{'ccuname'}.':'.$args->{'ccdomain'};
+# add crosslistings
+ if ($args->{'crsxlist'}) {
+ $cenv{'internal.crosslistings'}='';
+ if ($args->{'crsxlist'} =~ m/,/) {
+ @xlists = split/,/,$args->{'crsxlist'};
+ } else {
+ $xlists[0] = $args->{'crsxlist'};
+ }
+ if (@xlists > 0) {
+ foreach my $item (@xlists) {
+ my ($xl,$gp) = split/:/,$item;
+ my $addcheck = &Apache::lonnet::auto_new_course($$crsunum,$$crsudom,$xl,$cenv{'internal.courseowner'});
+ $cenv{'internal.crosslistings'} .= $item.',';
+ unless ($addcheck eq 'ok') {
+ push @badclasses, $xl;
+ }
+ }
+ $cenv{'internal.crosslistings'} =~ s/,$//;
+ }
+ }
+ if ($args->{'autoadds'}) {
+ $cenv{'internal.autoadds'}=$args->{'autoadds'};
+ }
+ if ($args->{'autodrops'}) {
+ $cenv{'internal.autodrops'}=$args->{'autodrops'};
+ }
+# check for notification of enrollment changes
+ my @notified = ();
+ if ($args->{'notify_owner'}) {
+ if ($args->{'ccuname'} ne '') {
+ push(@notified,$args->{'ccuname'}.':'.$args->{'ccdomain'});
+ }
+ }
+ if ($args->{'notify_dc'}) {
+ if ($uname ne '') {
+ push(@notified,$uname.':'.$udom);
+ }
+ }
+ if (@notified > 0) {
+ my $notifylist;
+ if (@notified > 1) {
+ $notifylist = join(',',@notified);
+ } else {
+ $notifylist = $notified[0];
+ }
+ $cenv{'internal.notifylist'} = $notifylist;
+ }
+ if (@badclasses > 0) {
+ my %lt=&Apache::lonlocal::texthash(
+ 'tclb' => 'The courses listed below were included as sections or crosslistings affiliated with your new LON-CAPA course. However, if automated course roster updates are enabled for this class, these particular sections/crosslistings will not contribute towards enrollment, because the user identified as the course owner for this LON-CAPA course',
+ 'dnhr' => 'does not have rights to access enrollment in these classes',
+ 'adby' => 'as determined by the policies of your institution on access to official classlists'
+ );
+ my $badclass_msg = $cenv{'internal.courseowner'}.') - '.$lt{'dnhr'}.
+ ' ('.$lt{'adby'}.')';
+ if ($context eq 'auto') {
+ $outcome .= $badclass_msg.$linefeed;
+ $outcome .= ''.$badclass_msg.$linefeed.'
'."\n";
+ foreach my $item (@badclasses) {
+ if ($context eq 'auto') {
+ $outcome .= " - $item\n";
+ } else {
+ $outcome .= "$item \n";
+ }
+ }
+ if ($context eq 'auto') {
+ $outcome .= $linefeed;
+ } else {
+ $outcome .= " \n";
+ }
+ }
+ }
+ if ($args->{'no_end_date'}) {
+ $args->{'endaccess'} = 0;
+ }
+ $cenv{'internal.autostart'}=$args->{'enrollstart'};
+ $cenv{'internal.autoend'}=$args->{'enrollend'};
+ $cenv{'default_enrollment_start_date'}=$args->{'startaccess'};
+ $cenv{'default_enrollment_end_date'}=$args->{'endaccess'};
+ if ($args->{'showphotos'}) {
+ $cenv{'internal.showphotos'}=$args->{'showphotos'};
+ }
+ $cenv{'internal.authtype'} = $args->{'authtype'};
+ $cenv{'internal.autharg'} = $args->{'autharg'};
+ if ( ($cenv{'internal.authtype'} =~ /^krb/) && ($cenv{'internal.autoadds'} == 1)) {
+ if (! defined($cenv{'internal.autharg'}) || $cenv{'internal.autharg'} eq '') {
+ my $krb_msg = &mt('As you did not include the default Kerberos domain to be used for authentication in this class, the institutional data used by the automated enrollment process must include the Kerberos domain for each new student');
+ if ($context eq 'auto') {
+ $outcome .= $krb_msg;
+ } else {
+ $outcome .= ''.$krb_msg.' ';
+ }
+ $outcome .= $linefeed;
+ }
+ }
+ if (($args->{'ccdomain'}) && ($args->{'ccuname'})) {
+ if ($args->{'setpolicy'}) {
+ $cenv{'policy.email'}=$args->{'ccuname'}.':'.$args->{'ccdomain'};
+ }
+ if ($args->{'setcontent'}) {
+ $cenv{'question.email'}=$args->{'ccuname'}.':'.$args->{'ccdomain'};
+ }
+ }
+ if ($args->{'reshome'}) {
+ $cenv{'reshome'}=$args->{'reshome'}.'/';
+ $cenv{'reshome'}=~s/\/+$/\//;
+ }
+#
+# course has keyed access
+#
+ if ($args->{'setkeys'}) {
+ $cenv{'keyaccess'}='yes';
+ }
+# if specified, key authority is not course, but user
+# only active if keyaccess is yes
+ if ($args->{'keyauth'}) {
+ my ($user,$domain) = split(':',$args->{'keyauth'});
+ $user = &LONCAPA::clean_username($user);
+ $domain = &LONCAPA::clean_username($domain);
+ if ($user ne '' && $domain ne '') {
+ $cenv{'keyauth'}=$user.':'.$domain;
+ }
+ }
+
+ if ($args->{'disresdis'}) {
+ $cenv{'pch.roles.denied'}='st';
+ }
+ if ($args->{'disablechat'}) {
+ $cenv{'plc.roles.denied'}='st';
+ }
+
+ # Record we've not yet viewed the Course Initialization Helper for this
+ # course
+ $cenv{'course.helper.not.run'} = 1;
+ #
+ # Use new Randomseed
+ #
+ $cenv{'rndseed'}=&Apache::lonnet::latest_rnd_algorithm_id();;
+ $cenv{'receiptalg'}=&Apache::lonnet::latest_receipt_algorithm_id();;
+ #
+ # The encryption code and receipt prefix for this course
+ #
+ $cenv{'internal.encseed'}=$Apache::lonnet::perlvar{'lonReceipt'}.$$.time.int(rand(9999));
+ $cenv{'internal.encpref'}=100+int(9*rand(99));
+ #
+ # By default, use standard grading
+ if (!defined($cenv{'grading'})) { $cenv{'grading'} = 'standard'; }
+
+ $outcome .= $linefeed.&mt('Setting environment').': '.
+ &Apache::lonnet::put('environment',\%cenv,$$crsudom,$$crsunum).$linefeed;
+#
+# Open all assignments
+#
+ if ($args->{'openall'}) {
+ my $storeunder=$$crsudom.'_'.$$crsunum.'.0.opendate';
+ my %storecontent = ($storeunder => time,
+ $storeunder.'.type' => 'date_start');
+
+ $outcome .= &mt('Opening all assignments').': '.&Apache::lonnet::cput
+ ('resourcedata',\%storecontent,$$crsudom,$$crsunum).$linefeed;
+ }
+#
+# Set first page
+#
+ unless (($args->{'nonstandard'}) || ($args->{'firstres'} eq 'blank')
+ || ($cloneid)) {
+ use LONCAPA::map;
+ $outcome .= &mt('Setting first resource').': ';
+
+ my $map = '/uploaded/'.$$crsudom.'/'.$$crsunum.'/default.sequence';
+ my ($errtext,$fatal)=&LONCAPA::map::mapread($map);
+
+ $outcome .= ($fatal?$errtext:'read ok').' - ';
+ my $title; my $url;
+ if ($args->{'firstres'} eq 'syl') {
+ $title=&mt('Syllabus');
+ $url='/public/'.$$crsudom.'/'.$$crsunum.'/syllabus';
+ } else {
+ $title=&mt('Navigate Contents');
+ $url='/adm/navmaps';
+ }
+
+ $LONCAPA::map::resources[1]=$title.':'.$url.':false:start:res';
+ (my $outtext,$errtext) = &LONCAPA::map::storemap($map,1);
+
+ if ($errtext) { $fatal=2; }
+ $outcome .= ($fatal?$errtext:'write ok').$linefeed;
+ }
+
+ return (1,$outcome);
+}
+
+############################################################
+############################################################
+
+sub course_type {
+ my ($cid) = @_;
+ if (!defined($cid)) {
+ $cid = $env{'request.course.id'};
+ }
+ if (defined($env{'course.'.$cid.'.type'})) {
+ return $env{'course.'.$cid.'.type'};
+ } else {
+ return 'Course';
+ }
+}
+
+sub group_term {
+ my $crstype = &course_type();
+ my %names = (
+ 'Course' => 'group',
+ 'Group' => 'team',
+ );
+ return $names{$crstype};
+}
sub icon {
my ($file)=@_;
- my $curfext = (split(/\./,$file))[-1];
+ my $curfext = lc((split(/\./,$file))[-1]);
my $iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/unknown.gif';
my $embstyle = &Apache::loncommon::fileembstyle($curfext);
if (!(!defined($embstyle) || $embstyle eq 'unk' || $embstyle eq 'hdn')) {
@@ -3437,9 +9746,263 @@ sub icon {
$curfext.".gif";
}
}
- return $iconname;
+ return &lonhttpdurl($iconname);
}
+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)=@_;
+ return $url;
+}
+
+sub connection_aborted {
+ my ($r)=@_;
+ $r->print(" ");$r->rflush();
+ my $c = $r->connection;
+ return $c->aborted();
+}
+
+# Escapes strings that may have embedded 's that will be put into
+# strings as 'strings'.
+sub escape_single {
+ my ($input) = @_;
+ $input =~ s/\\/\\\\/g; # Escape the \'s..(must be first)>
+ $input =~ s/\'/\\\'/g; # Esacpe the 's....
+ return $input;
+}
+
+# Same as escape_single, but escape's "'s This
+# can be used for "strings"
+sub escape_double {
+ my ($input) = @_;
+ $input =~ s/\\/\\\\/g; # Escape the /'s..(must be first)>
+ $input =~ s/\"/\\\"/g; # Esacpe the "s....
+ return $input;
+}
+
+# Escapes the last element of a full URL.
+sub escape_url {
+ my ($url) = @_;
+ my @urlslices = split(/\//, $url,-1);
+ my $lastitem = &escape(pop(@urlslices));
+ return join('/',@urlslices).'/'.$lastitem;
+}
+
+# -------------------------------------------------------- Initliaze user login
+sub init_user_environment {
+ my ($r, $username, $domain, $authhost, $form, $args) = @_;
+ my $lonids=$Apache::lonnet::perlvar{'lonIDsDir'};
+
+ my $public=($username eq 'public' && $domain eq 'public');
+
+# See if old ID present, if so, remove
+
+ my ($filename,$cookie,$userroles);
+ my $now=time;
+
+ if ($public) {
+ my $max_public=100;
+ my $oldest;
+ my $oldest_time=0;
+ for(my $next=1;$next<=$max_public;$next++) {
+ if (-e $lonids."/publicuser_$next.id") {
+ my $mtime=(stat($lonids."/publicuser_$next.id"))[9];
+ if ($mtime<$oldest_time || !$oldest_time) {
+ $oldest_time=$mtime;
+ $oldest=$next;
+ }
+ } else {
+ $cookie="publicuser_$next";
+ last;
+ }
+ }
+ if (!$cookie) { $cookie="publicuser_$oldest"; }
+ } else {
+ # if this isn't a robot, kill any existing non-robot sessions
+ if (!$args->{'robot'}) {
+ opendir(DIR,$lonids);
+ while ($filename=readdir(DIR)) {
+ if ($filename=~/^$username\_\d+\_$domain\_$authhost\.id$/) {
+ unlink($lonids.'/'.$filename);
+ }
+ }
+ closedir(DIR);
+ }
+# Give them a new cookie
+ my $id = ($args->{'robot'} ? 'robot'.$args->{'robot'}
+ : $now.$$.int(rand(10000)));
+ $cookie="$username\_$id\_$domain\_$authhost";
+
+# Initialize roles
+
+ $userroles=&Apache::lonnet::rolesinit($domain,$username,$authhost);
+ }
+# ------------------------------------ Check browser type and MathML capability
+
+ my ($httpbrowser,$clientbrowser,$clientversion,$clientmathml,
+ $clientunicode,$clientos) = &decode_user_agent($r);
+
+# -------------------------------------- Any accessibility options to remember?
+ if (($form->{'interface'}) && ($form->{'remember'} eq 'true')) {
+ foreach my $option ('imagesuppress','appletsuppress',
+ 'embedsuppress','fontenhance','blackwhite') {
+ if ($form->{$option} eq 'true') {
+ &Apache::lonnet::put('environment',{$option => 'on'},
+ $domain,$username);
+ } else {
+ &Apache::lonnet::del('environment',[$option],
+ $domain,$username);
+ }
+ }
+ }
+# ------------------------------------------------------------- Get environment
+
+ my %userenv = &Apache::lonnet::dump('environment',$domain,$username);
+ my ($tmp) = keys(%userenv);
+ if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
+ # default remote control to off
+ if ($userenv{'remote'} ne 'on') { $userenv{'remote'} = 'off'; }
+ } else {
+ undef(%userenv);
+ }
+ if (($userenv{'interface'}) && (!$form->{'interface'})) {
+ $form->{'interface'}=$userenv{'interface'};
+ }
+ $env{'environment.remote'}=$userenv{'remote'};
+ if ($userenv{'texengine'} eq 'ttm') { $clientmathml=1; }
+
+# --------------- Do not trust query string to be put directly into environment
+ foreach my $option ('imagesuppress','appletsuppress',
+ 'embedsuppress','fontenhance','blackwhite',
+ 'interface','localpath','localres') {
+ $form->{$option}=~s/[\n\r\=]//gs;
+ }
+# --------------------------------------------------------- Write first profile
+
+ {
+ my %initial_env =
+ ("user.name" => $username,
+ "user.domain" => $domain,
+ "user.home" => $authhost,
+ "browser.type" => $clientbrowser,
+ "browser.version" => $clientversion,
+ "browser.mathml" => $clientmathml,
+ "browser.unicode" => $clientunicode,
+ "browser.os" => $clientos,
+ "server.domain" => $Apache::lonnet::perlvar{'lonDefDomain'},
+ "request.course.fn" => '',
+ "request.course.uri" => '',
+ "request.course.sec" => '',
+ "request.role" => 'cm',
+ "request.role.adv" => $env{'user.adv'},
+ "request.host" => $ENV{'REMOTE_ADDR'},);
+
+ if ($form->{'localpath'}) {
+ $initial_env{"browser.localpath"} = $form->{'localpath'};
+ $initial_env{"browser.localres"} = $form->{'localres'};
+ }
+
+ if ($public) {
+ $initial_env{"environment.remote"} = "off";
+ }
+ if ($form->{'interface'}) {
+ $form->{'interface'}=~s/\W//gs;
+ $initial_env{"browser.interface"} = $form->{'interface'};
+ $env{'browser.interface'}=$form->{'interface'};
+ foreach my $option ('imagesuppress','appletsuppress',
+ 'embedsuppress','fontenhance','blackwhite') {
+ if (($form->{$option} eq 'true') ||
+ ($userenv{$option} eq 'on')) {
+ $initial_env{"browser.$option"} = "on";
+ }
+ }
+ }
+
+ foreach my $tool ('aboutme','blog','portfolio') {
+ $userenv{'availabletools.'.$tool} =
+ &Apache::lonnet::usertools_access($username,$domain,$tool,'reload');
+ }
+
+ $env{'user.environment'} = "$lonids/$cookie.id";
+
+ if (tie(my %disk_env,'GDBM_File',"$lonids/$cookie.id",
+ &GDBM_WRCREAT(),0640)) {
+ &_add_to_env(\%disk_env,\%initial_env);
+ &_add_to_env(\%disk_env,\%userenv,'environment.');
+ &_add_to_env(\%disk_env,$userroles);
+ if (ref($args->{'extra_env'})) {
+ &_add_to_env(\%disk_env,$args->{'extra_env'});
+ }
+ untie(%disk_env);
+ } else {
+ &Apache::lonnet::logthis("WARNING: ".
+ 'Could not create environment storage in lonauth: '.$!.' ');
+ return 'error: '.$!;
+ }
+ }
+ $env{'request.role'}='cm';
+ $env{'request.role.adv'}=$env{'user.adv'};
+ $env{'browser.type'}=$clientbrowser;
+
+ return $cookie;
+
+}
+
+sub _add_to_env {
+ my ($idf,$env_data,$prefix) = @_;
+ 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-^https?\://($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,$delete_enc) = @_;
+
+ &Apache::lonenc::check_decrypt(\$symb);
+ my $enc = $env{'request.enc'};
+ if ($delete_enc) {
+ delete($env{'request.enc'});
+ }
+
+ return ($symb,$enc);
+}
+
=pod
=back