tag
+
+=item * $hashref, a reference to a hash containing the data for the menus.
+
+=back
+
+Below is an example of such a hash. Only the 'text', 'default', and
+'select2' keys must appear as stated. keys(%menu) are the possible
+values for the first select menu. The text that coincides with the
+first menu value is given in $menu{$choice1}->{'text'}. The values
+and text for the second menu are given in the hash pointed to by
+$menu{$choice1}->{'select2'}.
+
+ my %menu = ( A1 => { text =>"Choice A1" ,
+ default => "B3",
+ select2 => {
+ B1 => "Choice B1",
+ B2 => "Choice B2",
+ B3 => "Choice B3",
+ B4 => "Choice B4"
+ }
+ },
+ A2 => { text =>"Choice A2" ,
+ default => "C2",
+ select2 => {
+ C1 => "Choice C1",
+ C2 => "Choice C2",
+ C3 => "Choice C3"
+ }
+ },
+ A3 => { text =>"Choice A3" ,
+ default => "D6",
+ select2 => {
+ D1 => "Choice D1",
+ D2 => "Choice D2",
+ D3 => "Choice D3",
+ D4 => "Choice D4",
+ D5 => "Choice D5",
+ D6 => "Choice D6",
+ D7 => "Choice D7"
+ }
+ }
+ );
+
+=cut
+
+sub linked_select_forms {
+ my ($formname,
+ $middletext,
+ $firstdefault,
+ $firstselectname,
+ $secondselectname,
+ $hashref
+ ) = @_;
+ my $second = "document.$formname.$secondselectname";
+ my $first = "document.$formname.$firstselectname";
+ # output the javascript to do the changing
+ my $result = '';
+ $result.="
+END
+ # output the initial values for the selection lists
+ $result .= "\n";
+ foreach my $value (sort(keys(%$hashref))) {
+ $result.=" {$value}->{'text'})." \n";
+ }
+ $result .= " \n";
+ my %select2 = %{$hashref->{$firstdefault}->{'select2'}};
+ $result .= $middletext;
+ $result .= "\n";
+ my $seconddefault = $hashref->{$firstdefault}->{'default'};
+ foreach my $value (sort(keys(%select2))) {
+ $result.=" \n";
+ }
+ $result .= " \n";
+ # return $debug;
+ return $result;
+} # end of sub linked_select_forms {
+
+=pod
+
+=item * help_open_topic($topic, $text, $stayOnPage, $width, $height)
+
+Returns a string corresponding to an HTML link to the given help
+$topic, where $topic corresponds to the name of a .tex file in
+/home/httpd/html/adm/help/tex, with underscores replaced by
+spaces.
+
+$text will optionally be linked to the same topic, allowing you to
+link text in addition to the graphic. If you do not want to link
+text, but wish to specify one of the later parameters, pass an
+empty string.
+
+$stayOnPage is a value that will be interpreted as a boolean. If true,
+the link will not open a new window. If false, the link will open
+a new window using Javascript. (Default is false.)
+
+$width and $height are optional numerical parameters that will
+override the width and height of the popped up window, which may
+be useful for certain help topics with big pictures included.
+
+=cut
+
+sub help_open_topic {
+ my ($topic, $text, $stayOnPage, $width, $height) = @_;
+ $text = "" if (not defined $text);
+ $stayOnPage = 0 if (not defined $stayOnPage);
+ if ($env{'browser.interface'} eq 'textual' ||
+ $env{'environment.remote'} eq 'off' ) {
+ $stayOnPage=1;
+ }
+ $width = 350 if (not defined $width);
+ $height = 400 if (not defined $height);
+ my $filename = $topic;
+ $filename =~ s/ /_/g;
+
+ my $template = "";
+ my $link;
+
+ $topic=~s/\W/\_/g;
+
+ if (!$stayOnPage)
+ {
+ $link = "javascript:void(open('/adm/help/${filename}.hlp', 'Help_for_$topic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))";
+ }
+ else
+ {
+ $link = "/adm/help/${filename}.hlp";
+ }
+
+ # Add the text
+ if ($text ne "")
+ {
+ $template .=
+ "".
+ "$text
' };
+ return $template;
+
+}
+
+# This is a quicky function for Latex cheatsheet editing, since it
+# appears in at least four places
+sub helpLatexCheatsheet {
+ my $other = shift;
+ my $addOther = '';
+ if ($other) {
+ $addOther = Apache::loncommon::help_open_topic($other, shift,
+ undef, undef, 600) .
+ '';
+ }
+ return ''.
+ $addOther .
+ &Apache::loncommon::help_open_topic("Greek_Symbols",'Greek Symbols',
+ undef,undef,600)
+ .' '.
+ &Apache::loncommon::help_open_topic("Other_Symbols",'Other Symbols',
+ undef,undef,600)
+ .'
';
+}
+
+sub help_open_menu {
+ my ($color,$topic,$component_help,$function,$faq,$bug,$stayOnPage,$width,$height,$text) = @_;
+ $text = "" if (not defined $text);
+ $stayOnPage = 0 if (not defined $stayOnPage);
+ if ($env{'browser.interface'} eq 'textual' ||
+ $env{'environment.remote'} eq 'off' ) {
+ $stayOnPage=1;
+ }
+ $width = 620 if (not defined $width);
+ $height = 600 if (not defined $height);
+ my $link='';
+ my $title = &mt('Get help');
+ my $origurl = $ENV{'REQUEST_URI'};
+ $origurl=~s|^/~|/priv/|;
+ my $timestamp = time;
+ foreach (\$color,\$function,\$topic,\$component_help,\$faq,\$bug,\$origurl) {
+ $$_ = &Apache::lonnet::escape($$_);
+ }
+ if (!$stayOnPage) {
+ $link = "javascript:helpMenu('open')";
+ } else {
+ $link = "javascript:helpMenu('display')";
+ }
+ my $banner_link = "/adm/helpmenu?page=banner&color=$color&function=$function&topic=$topic&component_help=$component_help&faq=$faq&bug=$bug&origurl=$origurl&stamp=$timestamp&stayonpage=$stayOnPage";
+ my $details_link = "/adm/helpmenu?page=body&color=$color&function=$function&topic=$topic&component_help=$component_help&faq=$faq&bug=$bug&origurl=$origurl&stamp=$timestamp";
+ my $template;
+ if ($text ne "") {
+ $template .=
+ "".
+ "$text '.
+ &help_open_topic($component_help,$help_text,$stayOnPage,
+ $width,$height).' '.$template.
+ '
';
+ }
+ }
+ if ($text ne '') { $template.='
' };
+ return $template;
+}
+
+sub help_open_bug {
+ my ($topic, $text, $stayOnPage, $width, $height) = @_;
+ unless ($env{'user.adv'}) { return ''; }
+ unless ($Apache::lonnet::perlvar{'BugzillaHost'}) { return ''; }
+ $text = "" if (not defined $text);
+ $stayOnPage = 0 if (not defined $stayOnPage);
+ if ($env{'browser.interface'} eq 'textual' ||
+ $env{'environment.remote'} eq 'off' ) {
+ $stayOnPage=1;
+ }
+ $width = 600 if (not defined $width);
+ $height = 600 if (not defined $height);
+
+ $topic=~s/\W+/\+/g;
+ my $link='';
+ my $template='';
+ my $url=$Apache::lonnet::perlvar{'BugzillaHost'}.'enter_bug.cgi?product=LON-CAPA&bug_file_loc='.
+ &Apache::lonnet::escape($ENV{'REQUEST_URI'}).'&component='.$topic;
+ if (!$stayOnPage)
+ {
+ $link = "javascript:void(open('$url', 'Bugzilla', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))";
+ }
+ else
+ {
+ $link = $url;
+ }
+ # Add the text
+ if ($text ne "")
+ {
+ $template .=
+ "".
+ "$text
' };
+ return $template;
+
+}
+
+sub help_open_faq {
+ my ($topic, $text, $stayOnPage, $width, $height) = @_;
+ unless ($env{'user.adv'}) { return ''; }
+ unless ($Apache::lonnet::perlvar{'FAQHost'}) { return ''; }
+ $text = "" if (not defined $text);
+ $stayOnPage = 0 if (not defined $stayOnPage);
+ if ($env{'browser.interface'} eq 'textual' ||
+ $env{'environment.remote'} eq 'off' ) {
+ $stayOnPage=1;
+ }
+ $width = 350 if (not defined $width);
+ $height = 400 if (not defined $height);
+
+ $topic=~s/\W+/\+/g;
+ my $link='';
+ my $template='';
+ my $url=$Apache::lonnet::perlvar{'FAQHost'}.'/fom/cache/'.$topic.'.html';
+ if (!$stayOnPage)
+ {
+ $link = "javascript:void(open('$url', 'FAQ-O-Matic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))";
+ }
+ else
+ {
+ $link = $url;
+ }
+
+ # Add the text
+ if ($text ne "")
+ {
+ $template .=
+ "".
+ "$text
' };
+ return $template;
+
+}
+
+###############################################################
+###############################################################
+
+=pod
+
+=item * change_content_javascript():
+
+This and the next function allow you to create small sections of an
+otherwise static HTML page that you can update on the fly with
+Javascript, even in Netscape 4.
+
+The Javascript fragment returned by this function (no EscriptE tag)
+must be written to the HTML page once. It will prove the Javascript
+function "change(name, content)". Calling the change function with the
+name of the section
+you want to update, matching the name passed to C, and
+the new content you want to put in there, will put the content into
+that area.
+
+B: Netscape 4 only reserves enough space for the changable area
+to contain room for the original contents. You need to "make space"
+for whatever changes you wish to make, and be B to check your
+code in Netscape 4. This feature in Netscape 4 is B powerful;
+it's adequate for updating a one-line status display, but little more.
+This script will set the space to 100% width, so you only need to
+worry about height in Netscape 4.
+
+Modern browsers are much less limiting, and if you can commit to the
+user not using Netscape 4, this feature may be used freely with
+pretty much any HTML.
+
+=cut
+
+sub change_content_javascript {
+ # If we're on Netscape 4, we need to use Layer-based code
+ if ($env{'browser.type'} eq 'netscape' &&
+ $env{'browser.version'} =~ /^4\./) {
+ return (<. $name is
+the name you will use to reference the area later; do not repeat the
+same name on a given HTML page more then once. $origContent is what
+the area will originally contain, which can be left blank.
+
+=cut
+
+sub changable_area {
+ my ($name, $origContent) = @_;
+
+ if ($env{'browser.type'} eq 'netscape' &&
+ $env{'browser.version'} =~ /^4\./) {
+ # If this is netscape 4, we need to use the Layer tag
+ return "$origContent $origContent ";
+ }
+}
+
+=pod
+
+=back
+
+=head1 Excel and CSV file utility routines
+
+=over 4
+
+=cut
+
+###############################################################
+###############################################################
+
+=pod
+
+=item * csv_translate($text)
+
+Translate $text to allow it to be output as a 'comma separated values'
+format.
+
+=cut
+
+###############################################################
+###############################################################
+sub csv_translate {
+ my $text = shift;
+ $text =~ s/\"/\"\"/g;
+ $text =~ s/\n/ /g;
+ return $text;
+}
+
+###############################################################
+###############################################################
+
+=pod
+
+=item * define_excel_formats
+
+Define some commonly used Excel cell formats.
+
+Currently supported formats:
+
+=over 4
+
+=item header
+
+=item bold
+
+=item h1
+
+=item h2
+
+=item h3
+
+=item h4
+
+=item i
+
+=item date
+
+=back
+
+Inputs: $workbook
+
+Returns: $format, a hash reference.
+
+=cut
+
+###############################################################
+###############################################################
+sub define_excel_formats {
+ my ($workbook) = @_;
+ my $format;
+ $format->{'header'} = $workbook->add_format(bold => 1,
+ bottom => 1,
+ align => 'center');
+ $format->{'bold'} = $workbook->add_format(bold=>1);
+ $format->{'h1'} = $workbook->add_format(bold=>1, size=>18);
+ $format->{'h2'} = $workbook->add_format(bold=>1, size=>16);
+ $format->{'h3'} = $workbook->add_format(bold=>1, size=>14);
+ $format->{'h4'} = $workbook->add_format(bold=>1, size=>12);
+ $format->{'i'} = $workbook->add_format(italic=>1);
+ $format->{'date'} = $workbook->add_format(num_format=>
+ 'mm/dd/yyyy hh:mm:ss');
+ return $format;
+}
+
+###############################################################
+###############################################################
+
+=pod
+
+=item * create_workbook
+
+Create an Excel worksheet. If it fails, output message on the
+request object and return undefs.
+
+Inputs: Apache request object
+
+Returns (undef) on failure,
+ Excel worksheet object, scalar with filename, and formats
+ from &Apache::loncommon::define_excel_formats on success
+
+=cut
+
+###############################################################
+###############################################################
+sub create_workbook {
+ my ($r) = @_;
+ #
+ # Create the excel spreadsheet
+ my $filename = '/prtspool/'.
+ $env{'user.name'}.'_'.$env{'user.domain'}.'_'.
+ time.'_'.rand(1000000000).'.xls';
+ my $workbook = Spreadsheet::WriteExcel->new('/home/httpd'.$filename);
+ if (! defined($workbook)) {
+ $r->log_error("Error creating excel spreadsheet $filename: $!");
+ $r->print(''.&mt("Unable to create new Excel file. ".
+ "This error has been logged. ".
+ "Please alert your LON-CAPA administrator").
+ '
');
+ return (undef);
+ }
+ #
+ $workbook->set_tempdir('/home/httpd/perl/tmp');
+ #
+ my $format = &Apache::loncommon::define_excel_formats($workbook);
+ return ($workbook,$filename,$format);
+}
+
+###############################################################
+###############################################################
+
+=pod
+
+=item * create_text_file
+
+Create a file to write to and eventually make available to the usre.
+If file creation fails, outputs an error message on the request object and
+return undefs.
+
+Inputs: Apache request object, and file suffix
+
+Returns (undef) on failure,
+ Filehandle and filename on success.
+
+=cut
+
+###############################################################
+###############################################################
+sub create_text_file {
+ my ($r,$suffix) = @_;
+ if (! defined($suffix)) { $suffix = 'txt'; };
+ my $fh;
+ my $filename = '/prtspool/'.
+ $env{'user.name'}.'_'.$env{'user.domain'}.'_'.
+ time.'_'.rand(1000000000).'.'.$suffix;
+ $fh = Apache::File->new('>/home/httpd'.$filename);
+ if (! defined($fh)) {
+ $r->log_error("Couldn't open $filename for output $!");
+ $r->print("Problems occured in creating the output file. ".
+ "This error has been logged. ".
+ "Please alert your LON-CAPA administrator.");
+ }
+ return ($fh,$filename)
+}
+
+
+=pod
+
+=back
+
+=cut
+
+###############################################################
+## Home server list generating code ##
+###############################################################
+
+=pod
+
+=head1 Home Server option list generating code
+
+=over 4
+
+=item * get_domains()
+
+Returns an array containing each of the domains listed in the hosts.tab
+file.
+
+=cut
+
+#-------------------------------------------
+sub get_domains {
+ # The code below was stolen from "The Perl Cookbook", p 102, 1st ed.
+ my @domains;
+ my %seen;
+ foreach (sort values(%Apache::lonnet::hostdom)) {
+ push (@domains,$_) unless $seen{$_}++;
+ }
+ return @domains;
+}
+
+# ------------------------------------------
+
+sub domain_select {
+ my ($name,$value,$multiple)=@_;
+ my %domains=map {
+ $_ => $_.' '.$Apache::lonnet::domaindescription{$_}
+ } &get_domains;
+ if ($multiple) {
+ $domains{''}=&mt('Any domain');
+ return &multiple_select_form($name,$value,4,\%domains);
+ } else {
+ return &select_form($name,$value,%domains);
+ }
+}
+
+#-------------------------------------------
+
+=pod
+
+=item * multiple_select_form($name,$value,$size,$hash,$order)
+
+Returns a string containing a element int multiple mode
+
+
+Args:
+ $name - name of the element
+ $value - sclara or array ref of values that should already be selected
+ $size - number of rows long the select element is
+ $hash - the elements should be 'option' => 'shown text'
+ (shown text should already have been &mt())
+ $order - (optional) array ref of the order to show the elments in
+
+=cut
+
+#-------------------------------------------
+sub multiple_select_form {
+ my ($name,$value,$size,$hash,$order)=@_;
+ my %selected = map { $_ => 1 } ref($value)?@{$value}:($value);
+ my $output='';
+ if (! defined($size)) {
+ $size = 4;
+ if (scalar(keys(%$hash))<4) {
+ $size = scalar(keys(%$hash));
+ }
+ }
+ $output.="\n";
+ my @order = ref($order) ? @$order
+ : sort(keys(%$hash));
+ foreach my $key (@order) {
+ $output.='{$key}." \n";
+ }
+ $output.=" \n";
+ return $output;
+}
+
+#-------------------------------------------
+
+=pod
+
+=item * select_form($defdom,$name,%hash)
+
+Returns a string containing a form to
+allow a user to select options from a hash option_name => displayed text.
+See lonrights.pm for an example invocation and use.
+
+=cut
+
+#-------------------------------------------
+sub select_form {
+ my ($def,$name,%hash) = @_;
+ my $selectform = "\n";
+ my @keys;
+ if (exists($hash{'select_form_order'})) {
+ @keys=@{$hash{'select_form_order'}};
+ } else {
+ @keys=sort(keys(%hash));
+ }
+ foreach (@keys) {
+ $selectform.="".&mt($hash{$_})." \n";
+ }
+ $selectform.=" ";
+ return $selectform;
+}
+
+sub gradeleveldescription {
+ my $gradelevel=shift;
+ my %gradelevels=(0 => 'Not specified',
+ 1 => 'Grade 1',
+ 2 => 'Grade 2',
+ 3 => 'Grade 3',
+ 4 => 'Grade 4',
+ 5 => 'Grade 5',
+ 6 => 'Grade 6',
+ 7 => 'Grade 7',
+ 8 => 'Grade 8',
+ 9 => 'Grade 9',
+ 10 => 'Grade 10',
+ 11 => 'Grade 11',
+ 12 => 'Grade 12',
+ 13 => 'Grade 13',
+ 14 => '100 Level',
+ 15 => '200 Level',
+ 16 => '300 Level',
+ 17 => '400 Level',
+ 18 => 'Graduate Level');
+ return &mt($gradelevels{$gradelevel});
+}
+
+sub select_level_form {
+ my ($deflevel,$name)=@_;
+ unless ($deflevel) { $deflevel=0; }
+ my $selectform = "\n";
+ for (my $i=0; $i<=18; $i++) {
+ $selectform.="".&gradeleveldescription($i)." \n";
+ }
+ $selectform.=" ";
+ return $selectform;
+}
+
+#-------------------------------------------
+
+=pod
+
+=item * select_dom_form($defdom,$name,$includeempty)
+
+Returns a string containing a form to
+allow a user to select the domain to preform an operation in.
+See loncreateuser.pm for an example invocation and use.
+
+If the $includeempty flag is set, it also includes an empty choice ("no domain
+selected");
+
+=cut
+
+#-------------------------------------------
+sub select_dom_form {
+ my ($defdom,$name,$includeempty) = @_;
+ my @domains = get_domains();
+ if ($includeempty) { @domains=('',@domains); }
+ my $selectdomain = "\n";
+ foreach (@domains) {
+ $selectdomain.="$_ \n";
+ }
+ $selectdomain.=" ";
+ return $selectdomain;
+}
+
+#-------------------------------------------
+
+=pod
+
+=item * get_library_servers($domain)
+
+Returns a hash which contains keys like '103l3' and values like
+'kirk.lite.msu.edu'. All of the keys will be for machines in the
+given $domain.
+
+=cut
+
+#-------------------------------------------
+sub get_library_servers {
+ my $domain = shift;
+ my %library_servers;
+ foreach (keys(%Apache::lonnet::libserv)) {
+ if ($Apache::lonnet::hostdom{$_} eq $domain) {
+ $library_servers{$_} = $Apache::lonnet::hostname{$_};
+ }
+ }
+ return %library_servers;
+}
+
+#-------------------------------------------
+
+=pod
+
+=item * home_server_option_list($domain)
+
+returns a string which contains an list to be used in a
+ form input. See loncreateuser.pm for an example.
+
+=cut
+
+#-------------------------------------------
+sub home_server_option_list {
+ my $domain = shift;
+ my %servers = &get_library_servers($domain);
+ my $result = '';
+ foreach (sort keys(%servers)) {
+ $result.=
+ ''.$_.' '.$servers{$_}." \n";
+ }
+ return $result;
+}
+
+=pod
+
+=back
+
+=cut
+
+###############################################################
+## Decoding User Agent ##
+###############################################################
+
+=pod
+
+=head1 Decoding the User Agent
+
+=over 4
+
+=item * &decode_user_agent()
+
+Inputs: $r
+
+Outputs:
+
+=over 4
+
+=item * $httpbrowser
+
+=item * $clientbrowser
+
+=item * $clientversion
+
+=item * $clientmathml
+
+=item * $clientunicode
+
+=item * $clientos
+
+=back
+
+=back
+
+=cut
+
+###############################################################
+###############################################################
+sub decode_user_agent {
+ my ($r)=@_;
+ my @browsertype=split(/\&/,$Apache::lonnet::perlvar{"lonBrowsDet"});
+ my %mathcap=split(/\&/,$$Apache::lonnet::perlvar{"lonMathML"});
+ my $httpbrowser=$ENV{"HTTP_USER_AGENT"};
+ if (!$httpbrowser && $r) { $httpbrowser=$r->header_in('User-Agent'); }
+ my $clientbrowser='unknown';
+ my $clientversion='0';
+ my $clientmathml='';
+ my $clientunicode='0';
+ for (my $i=0;$i<=$#browsertype;$i++) {
+ my ($bname,$match,$notmatch,$vreg,$minv,$univ)=split(/\:/,$browsertype[$i]);
+ if (($httpbrowser=~/$match/i) && ($httpbrowser!~/$notmatch/i)) {
+ $clientbrowser=$bname;
+ $httpbrowser=~/$vreg/i;
+ $clientversion=$1;
+ $clientmathml=($clientversion>=$minv);
+ $clientunicode=($clientversion>=$univ);
+ }
+ }
+ my $clientos='unknown';
+ if (($httpbrowser=~/linux/i) ||
+ ($httpbrowser=~/unix/i) ||
+ ($httpbrowser=~/ux/i) ||
+ ($httpbrowser=~/solaris/i)) { $clientos='unix'; }
+ if (($httpbrowser=~/vax/i) ||
+ ($httpbrowser=~/vms/i)) { $clientos='vms'; }
+ if ($httpbrowser=~/next/i) { $clientos='next'; }
+ if (($httpbrowser=~/mac/i) ||
+ ($httpbrowser=~/powerpc/i)) { $clientos='mac'; }
+ if ($httpbrowser=~/win/i) { $clientos='win'; }
+ if ($httpbrowser=~/embed/i) { $clientos='pda'; }
+ return ($httpbrowser,$clientbrowser,$clientversion,$clientmathml,
+ $clientunicode,$clientos,);
+}
+
+###############################################################
+## Authentication changing form generation subroutines ##
+###############################################################
+##
+## All of the authform_xxxxxxx subroutines take their inputs in a
+## hash, and have reasonable default values.
+##
+## formname = the name given in the
+ENDROLE
+ my $titleinfo = ''.$title.' Construction Space :'.
+ ''.
+ $titleinfo.' '.$roleinfo.'
';
+ if ($env{'request.state'} eq 'construct') {
+ if ($notopbar) {
+ $bodytag .= $titletable;
+ } else {
+ $bodytag .= &Apache::lonmenu::menubuttons($forcereg,'web',$forcereg,$titletable);
+ }
+ } else {
+ if ($notopbar) {
+ $bodytag .= $titletable;
+ } else {
+ $bodytag .= &Apache::lonmenu::menubuttons($forcereg,'web',$forcereg).
+ $titletable;
+ }
+ }
+ return $bodytag;
+ }
+
+#
+# Top frame rendering, Remote is up
+#
+ my $titleinfo = ' '.$title.' '.&mt('Switch to Inline Menu Mode').' ';
+ #
+ return(<
+
+$upperleft
+$messages
+
+
+$titleinfo $dc_info $menu
+
+
+ $env{'environment.firstname'}
+ $env{'environment.middlename'}
+ $env{'environment.lastname'}
+ $env{'environment.generation'}
+
+
+
+
+$role
+
+$realm
+".
+ &mt('Continue').' '.
+ $endbodytag;
+ }
+ return $endbodytag;
+}
+
+=pod
+
+=over 4
+
+=item * &headtag()
+
+Returns a uniform footer for LON-CAPA web pages.
+
+Inputs: $title - optional title for the head
+ $head_extra - optional extra HTML to put inside the
+ $args - optional arguments
+ force_register - if is true call registerurl so the remote is
+ informed
+
+ redirect - array ref of seconds before redirect occurs
+ url to redirect to
+ (side effect of setting
+ $env{'internal.head.redirect'} to the url
+ redirected too)
+=back
+
+=cut
+
+sub headtag {
+ my ($title,$head_extra,$args) = @_;
+
+ my $result =
+ ''.
+ &Apache::lonxml::fontsettings().
+ &Apache::lonhtmlcommon::htmlareaheaders();
+
+ if ($args->{'force_register'}) {
+ $result .= &Apache::lonmenu::registerurl(1);
+ }
+
+ if (ref($args->{'redirect'})) {
+ my ($time,$url) = @{$args->{'redirect'}};
+ $url = &Apache::lonenc::check_encrypt($url);
+ $env{'internal.head.redirect'} = $url;
+ $result.=< LON-CAPA '.&mt($title).' '.$head_extra;
+ return $result;
+}
+
+=pod
+
+=over 4
+
+=item * &endheadtag()
+
+Returns a uniform for LON-CAPA web pages.
+
+Inputs: none
+
+=back
+
+=cut
+
+sub endheadtag {
+ return '';
+}
+
+=pod
+
+=over 4
+
+=item * &head()
+
+Returns a uniform complete .. section for LON-CAPA web pages.
+
+Inputs: $title - optional title for the page
+ $head_extra - optional extra HTML to put inside the
+=back
+
+=cut
+
+sub head {
+ my ($title,$head_extra,$args) = @_;
+ return &headtag($title,$head_extra,$args).&endheadtag();
+}
+
+=pod
+
+=over 4
+
+=item * &start_page()
+
+Returns a complete .. section for LON-CAPA web pages.
+
+Inputs: $title - optional title for the page
+ $head_extra - optional extra HTML to incude inside the
+ $args - additional optional args supported are:
+ only_body -> is true will set &bodytag() onlybodytag
+ arg on
+ no_nav_bar -> is true will set &bodytag() notopbar arg on
+ add_entries -> additional attributes to add to the
+ domain -> force to color decorate a page for a
+ specific domain
+ function -> force usage of a specific rolish color
+ scheme
+ redirect -> see &headtag()
+ bgcolor -> override the default page bg color
+ js_ready -> return a string ready for being used in
+ a javascript writeln
+ html_encode -> return a string ready for being used in
+ a html attribute
+ force_register -> if is true will turn on the &bodytag()
+ $forcereg arg
+ body_title -> alternate text to use instead of $title
+ in the title box that appears, this text
+ is not auto translated like the $title is
+ frameset -> if true will start with a
+ rather than
+=back
+
+=cut
+
+sub start_page {
+ my ($title,$head_extra,$args) = @_;
+ #&Apache::lonnet::logthis("start_page ".join(':',caller(0)));
+ my %head_args;
+ foreach my $arg ('redirect','force_register') {
+ if (defined($args->{$arg})) {
+ $head_args{$arg} = $args->{$arg};
+ }
+ }
+
+ $env{'internal.start_page'}++;
+ my $result =
+ &Apache::lonxml::xmlbegin().
+ &headtag($title,$head_extra,\%head_args).&endheadtag();
+ if ($args->{'frameset'}) {
+ my $attr_string = &make_attr_string($args->{'force_register'},
+ $args->{'add_entries'});
+ $result .= "\n\n";
+ } else {
+ $result .=
+ &bodytag($title,
+ $args->{'function'}, $args->{'add_entries'},
+ $args->{'only_body'}, $args->{'domain'},
+ $args->{'force_register'}, $args->{'body_title'},
+ $args->{'no_nav_bar'}, $args->{'bgcolor'});
+ }
+ if ($args->{'js_ready'}) {
+ $result = &js_ready($result);
+ }
+ if ($args->{'html_encode'}) {
+ $result = &html_encode($result);
+ }
+ return $result;
+}
+
+
+=pod
+
+=over 4
+
+=item * &head()
+
+Returns a complete section for LON-CAPA web pages.
+
+Inputs: $args - additional optional args supported are:
+ js_ready -> return a string ready for being used in
+ a javascript writeln
+ html_encode -> return a string ready for being used in
+ a html attribute
+ frameset -> if true will start with a
+ rather than
+=back
+
+=cut
+
+sub end_page {
+ my ($args) = @_;
+ #&Apache::lonnet::logthis("end_page ".join(':',caller(0)));
+ $env{'internal.end_page'}++;
+ my $result;
+ if ($args->{'discussion'}) {
+ my ($target,$parser);
+ if (ref($args->{'discussion'})) {
+ ($target,$parser) =($args->{'discussion'}{'target'},
+ $args->{'discussion'}{'parser'});
+ }
+ $result .= &Apache::lonxml::xmlend($target,$parser);
+ }
+
+ if ($args->{'frameset'}) {
+ $result .= ' ';
+ } else {
+ $result .= &endbodytag();
+ }
+ $result .= "\n";
+
+ if ($args->{'js_ready'}) {
+ $result = &js_ready($result);
+ }
+
+ if ($args->{'html_encode'}) {
+ $result = &html_encode($result);
+ }
+
+ return $result;
+}
+
+sub html_encode {
+ my ($result) = @_;
+
+ $result = &HTML::Entities::encode($result,'<>&"');
+
+ return $result;
+}
+sub js_ready {
+ my ($result) = @_;
+
+ $result =~ s/[\n\r]/ /xmsg;
+ $result =~ s/\\/\\\\/xmsg;
+ $result =~ s/'/\\'/xmsg;
+ $result =~ s{}{}xmsg;
+
+ return $result;
+}
+
+sub validate_page {
+ if ( exists($env{'internal.start_page'})
+ && $env{'internal.start_page'} > 1) {
+ &Apache::lonnet::logthis('start_page called multiple times '.
+ $env{'internal.start_page'}.' '.
+ $ENV{'request.filename'});
+ }
+ if ( exists($env{'internal.end_page'})
+ && $env{'internal.end_page'} > 1) {
+ &Apache::lonnet::logthis('end_page called multiple times '.
+ $env{'internal.end_page'}.' '.
+ $env{'request.filename'});
+ }
+ if ( exists($env{'internal.start_page'})
+ && ! exists($env{'internal.end_page'})) {
+ &Apache::lonnet::logthis('start_page called without end_page '.
+ $env{'request.filename'});
+ }
+ if ( ! exists($env{'internal.start_page'})
+ && exists($env{'internal.end_page'})) {
+ &Apache::lonnet::logthis('end_page called without start_page'.
+ $env{'request.filename'});
+ }
+}
+
+sub simple_error_page {
+ my ($r,$title,$msg) = @_;
+ my $page =
+ &Apache::loncommon::start_page($title).
+ &mt($msg).
+ &Apache::loncommon::end_page();
+ if (ref($r)) {
+ $r->print($page);
+ return;
+ }
+ return $page;
+}
+###############################################
+
+=pod
+
+=over 4
+
+=item get_users_function
+
+Used by &bodytag to determine the current users primary role.
+Returns either 'student','coordinator','admin', or 'author'.
+
+=cut
+
+###############################################
+sub get_users_function {
+ my $function = 'student';
+ if ($env{'request.role'}=~/^(cc|in|ta|ep)/) {
+ $function='coordinator';
+ }
+ if ($env{'request.role'}=~/^(su|dc|ad|li)/) {
+ $function='admin';
+ }
+ if (($env{'request.role'}=~/^(au|ca)/) ||
+ ($ENV{'REQUEST_URI'}=~/^(\/priv|\~)/)) {
+ $function='author';
+ }
+ return $function;
+}
+
+###############################################
+
+=pod
+
+=item check_user_status
+
+Determines current status of supplied role for a
+specific user. Roles can be active, previous or future.
+
+Inputs:
+user's domain, user's username, course's domain,
+course's number, optional section/group.
+
+Outputs:
+role status: active, previous or future.
+
+=cut
+
+sub check_user_status {
+ my ($udom,$uname,$cdom,$crs,$role,$secgrp) = @_;
+ my %userinfo = &Apache::lonnet::dump('roles',$udom,$uname);
+ my @uroles = keys %userinfo;
+ my $srchstr;
+ my $active_chk = 'none';
+ if (@uroles > 0) {
+ if (($role eq 'cc') || ($secgrp eq '') || (!defined($secgrp))) {
+ $srchstr = '/'.$cdom.'/'.$crs.'_'.$role;
+ } else {
+ $srchstr = '/'.$cdom.'/'.$crs.'/'.$secgrp.'_'.$role; }
+ if (grep/^$srchstr$/,@uroles) {
+ my $role_end = 0;
+ my $role_start = 0;
+ $active_chk = 'active';
+ if ($userinfo{$srchstr} =~ m/^($role)_(\d+)/) {
+ $role_end = $2;
+ if ($userinfo{$srchstr} =~ m/^($role)_($role_end)_(\d+)$/) {
+ $role_start = $3;
+ }
+ }
+ if ($role_start > 0) {
+ if (time < $role_start) {
+ $active_chk = 'future';
+ }
+ }
+ if ($role_end > 0) {
+ if (time > $role_end) {
+ $active_chk = 'previous';
+ }
+ }
+ }
+ }
+ return $active_chk;
+}
+
+###############################################
+
+=pod
+
+=item get_sections
+
+Determines all the sections for a course including
+sections with students and sections containing other roles.
+Incoming parameters: domain, course number, reference to
+section hash (keys to be section/group IDs), reference to
+array containing roles for which sections should be gathered
+(optional). If the fourth argument is undefined, sections
+are gathered for any role.
+
+Returns number of sections.
+
+=cut
+
+###############################################
+sub get_sections {
+ my ($cdom,$cnum,$sectioncount,$possible_roles) = @_;
+ if (!($cdom && $cnum)) { return 0; }
+ my $numsections = 0;
+
+ if (!defined($possible_roles) || (grep/^st$/,@$possible_roles)) {
+ my ($classlist) = &Apache::loncoursedata::get_classlist($cdom,$cnum);
+ my $sec_index = &Apache::loncoursedata::CL_SECTION();
+ my $status_index = &Apache::loncoursedata::CL_STATUS();
+ while (my ($student,$data) = each %$classlist) {
+ my ($section,$status) = ($data->[$sec_index],
+ $data->[$status_index]);
+ unless ($section eq '-1' || $section =~ /^\s*$/) {
+ if (!defined($$sectioncount{$section})) { $numsections++; }
+ $$sectioncount{$section}++;
+ }
+ }
+ }
+ my %courseroles = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum);
+ foreach my $user (sort(keys(%courseroles))) {
+ if ($user !~ /^(\w{2})/) { next; }
+ my ($role) = ($user =~ /^(\w{2})/);
+ if ($possible_roles && !(grep(/^$role$/,@$possible_roles))) { next; }
+ my $section;
+ if ($role eq 'cr' &&
+ $user =~ m-^$role/[^/]*/[^/]*/[^/]*:[^:]*:[^:]*:(\w+)-) {
+ $section=$1;
+ }
+ if ($user =~ /^$role:[^:]*:[^:]*:(\w+)/) { $section=$1; }
+ if (!defined($section) || $section eq '-1') { next; }
+ if (!defined($$sectioncount{$section})) { $numsections++; }
+ $$sectioncount{$section}++;
+ }
+ return $numsections;
+}
+
+###############################################
+
+=pod
+
+=item coursegroups
+
+Retrieve information about groups in a course,
+
+Input:
+1. Reference to hash to populate with group information.
+2. Optional course domain
+3. Optional course number
+4. Optional group name
+
+Course domain and number will be taken from user's
+environment if not supplied. Optional group name will'
+be passed to lonnet::get_coursegroups() as a regexp to
+use in the call to the dump function.
+
+Output
+Returns number of groups in the course (subject to the
+optional group name filter).
+
+Side effects:
+Populates the referenced curr_groups hash, with key,
+value pairs. Keys are group names, corresponding values
+are scalars containing group information in XML. This
+can be sent to &get_group_settings() to be parsed.
+
+=cut
+
+###############################################
+
+sub coursegroups {
+ my ($curr_groups,$cdom,$cnum,$group) = @_;
+ my $numgroups;
+ if (!defined($cdom) || !defined($cnum)) {
+ my $cid = $env{'request.course.id'};
+ $cdom = $env{'course.'.$cid.'.domain'};
+ $cnum = $env{'course.'.$cid.'.num'};
+ }
+ %{$curr_groups} = &Apache::lonnet::get_coursegroups($cdom,$cnum,$group);
+ my ($tmp) = keys(%{$curr_groups});
+ if ($tmp=~/^error:/) {
+ unless ($tmp eq 'error: 2 tie(GDBM) Failed while attempting dump') {
+ &logthis('Error retrieving groups: '.$tmp.' in '.$cnum.':'.
+ $cdom);
+ }
+ $numgroups = 0;
+ } else {
+ $numgroups = keys(%{$curr_groups});
+ }
+ return $numgroups;
+}
+
+###############################################
+
+=pod
+
+=item get_group_settings
+
+Uses TokeParser to extract group information from the
+XML used to describe course groups.
+
+Input:
+Scalar containing XML - as retrieved from &coursegroups().
+
+Output:
+Hash containing group information as key=values for (a), and
+hash of hashes for (b)
+
+Keys (in two categories):
+(a) groupname, creator, creation, modified, startdate,enddate.
+Corresponding values are name of the group, creator of the group
+(username:domain), UNIX time for date group was created, and
+settings were last modified, and default start and end access
+times for group members.
+
+(b) functions returned in hash of hashes.
+Outer hash key is functions.
+Inner hash keys are chat,discussion,email,files,homepage,roster.
+Corresponding values are either on or off, depending on
+whether this type of functionality is available for the group.
+
+=cut
+
+###############################################
+
+sub get_group_settings {
+ my ($groupinfo)=@_;
+ my $parser=HTML::TokeParser->new(\$groupinfo);
+ my $token;
+ my $tool = '';
+ my $role = '';
+ my %content=();
+ while ($token=$parser->get_token) {
+ if ($token->[0] eq 'S') {
+ my $entry=$token->[1];
+ if ($entry eq 'functions' || $entry eq 'autosec') {
+ %{$content{$entry}} = ();
+ $tool = $entry;
+ } elsif ($entry eq 'role') {
+ if ($tool eq 'autosec') {
+ $role = $token->[2]{id};
+ }
+ } else {
+ my $value=$parser->get_text('/'.$entry);
+ if ($entry eq 'name') {
+ if ($tool eq 'functions') {
+ my $function = $token->[2]{id};
+ $content{$tool}{$function} = $value;
+ }
+ } elsif ($entry eq 'groupname') {
+ $content{$entry}=&Apache::lonnet::unescape($value);
+ } elsif (($entry eq 'roles') || ($entry eq 'types') ||
+ ($entry eq 'sectionpick') || ($entry eq 'defpriv')) {
+ push(@{$content{$entry}},$value);
+ } elsif ($entry eq 'section') {
+ if ($tool eq 'autosec' && $role ne '') {
+ push(@{$content{$tool}{$role}},$value);
+ }
+ } else {
+ $content{$entry}=$value;
+ }
+ }
+ } elsif ($token->[0] eq 'E') {
+ if ($token->[1] eq 'functions' || $token->[1] eq 'autosec') {
+ $tool = '';
+ } elsif ($token->[1] eq 'role') {
+ $role = '';
+ }
+
+ }
+ }
+ return %content;
+}
+
+sub check_group_access {
+ my ($group) = @_;
+ my $access = 1;
+ my $now = time;
+ my ($start,$end) = split(/\./,$env{'user.role.gr/'.$env{'request.course,id'}.'/'.$group});
+ if (($end!=0) && ($end<$now)) { $access = 0; }
+ if (($start!=0) && ($start>$now)) { $access=0; }
+ return $access;
+}
+
+###############################################
+
+=pod
+
+=item get_course_users
+
+Retrieves usernames:domains for users in the specified course
+with specific role(s), and access status.
+
+Incoming parameters:
+1. course domain
+2. course number
+3. access status: users must have - either active,
+previous, future, or all.
+4. reference to array of permissible roles
+5. reference to array of section restrictions (optional)
+6. reference to results object (hash of hashes).
+7. reference to optional userdata hash
+Keys of top level hash are roles.
+Keys of inner hashes are username:domain, with
+values set to access type.
+Optional userdata hash returns an array with arguments in the
+same order as loncoursedata::get_classlist() for student data.
+
+Entries for end, start, section and status are blank because
+of the possibility of multiple values for non-student roles.
+
+=cut
+
+###############################################
+
+sub get_course_users {
+ my ($cdom,$cnum,$types,$roles,$sections,$users,$userdata) = @_;
+ my %idx = ();
+
+ $idx{udom} = &Apache::loncoursedata::CL_SDOM();
+ $idx{uname} = &Apache::loncoursedata::CL_SNAME();
+ $idx{end} = &Apache::loncoursedata::CL_END();
+ $idx{start} = &Apache::loncoursedata::CL_START();
+ $idx{id} = &Apache::loncoursedata::CL_ID();
+ $idx{section} = &Apache::loncoursedata::CL_SECTION();
+ $idx{fullname} = &Apache::loncoursedata::CL_FULLNAME();
+ $idx{status} = &Apache::loncoursedata::CL_STATUS();
+
+ if (grep(/^st$/,@{$roles})) {
+ my ($classlist,$keylist)=&Apache::loncoursedata::get_classlist($cdom,$cnum);
+ my $now = time;
+ foreach my $student (keys(%{$classlist})) {
+ my $match = 0;
+ if ((ref($sections) eq 'ARRAY') && (@{$sections} > 0)) {
+ unless(grep(/^\Q$$classlist{$student}[$idx{section}]\E$/,
+ @{$sections})) {
+ next;
+ }
+ }
+ if (defined($$types{'active'})) {
+ if ($$classlist{$student}[$idx{status}] eq 'Active') {
+ push(@{$$users{st}{$student}},'active');
+ $match = 1;
+ }
+ }
+ if (defined($$types{'previous'})) {
+ if ($$classlist{$student}[$idx{end}] <= $now) {
+ push(@{$$users{st}{$student}},'previous');
+ $match = 1;
+ }
+ }
+ if (defined($$types{'future'})) {
+ if (($$classlist{$student}[$idx{start}] > $now) && ($$classlist{$student}[$idx{end}] > $now) || ($$classlist{$student}[$idx{end}] == 0) || ($$classlist{$student}[$idx{end}] eq '')) {
+ push(@{$$users{st}{$student}},'future');
+ $match = 1;
+ }
+ }
+ if ($match && defined($userdata)) {
+ $$userdata{$student} = $$classlist{$student};
+ }
+ }
+ }
+ if ((@{$roles} > 0) && (@{$roles} ne "st")) {
+ my @coursepersonnel = &Apache::lonnet::getkeys('nohist_userroles',$cdom,$cnum);
+ foreach my $person (@coursepersonnel) {
+ my $match = 0;
+ my ($role,$user) = ($person =~ /^([^:]*):([^:]+:[^:]+)/);
+ $user =~ s/:$//;
+ if (($role) && (grep(/^\Q$role\E$/,@{$roles}))) {
+ my ($uname,$udom,$usec) = split(/:/,$user);
+ if ($usec ne '' && (ref($sections) eq 'ARRAY') &&
+ @{$sections} > 0) {
+ unless(grep(/^\Q$usec\E$/,@{$sections})) {
+ next;
+ }
+ }
+ if ($uname ne '' && $udom ne '') {
+ my $status = &check_user_status($udom,$uname,$cdom,$cnum,$role);
+ foreach my $type (keys(%{$types})) {
+ if ($status eq $type) {
+ @{$$users{$role}{$user}} = $type;
+ $match = 1;
+ }
+ }
+ if ($match && defined($userdata) &&
+ !exists($$userdata{$uname.':'.$udom})) {
+ &get_user_info($udom,$uname,\%idx,$userdata);
+ }
+ }
+ }
+ }
+ if (grep(/^ow$/,@{$roles})) {
+ if ((defined($cdom)) && (defined($cnum))) {
+ my %csettings = &Apache::lonnet::get('environment',['internal.courseowner'],$cdom,$cnum);
+ if ( defined($csettings{'internal.courseowner'}) ) {
+ my $owner = $csettings{'internal.courseowner'};
+ @{$$users{'ow'}{$owner.':'.$cdom}} = 'any';
+ if (defined($userdata) &&
+ !exists($$userdata{$owner.':'.$cdom})) {
+ &get_user_info($cdom,$owner,\%idx,$userdata);
+ }
+ }
+ }
+ }
+ }
+ return;
+}
+
+sub get_user_info {
+ my ($udom,$uname,$idx,$userdata) = @_;
+ $$userdata{$uname.':'.$udom}[$$idx{fullname}] =
+ &plainname($uname,$udom,'lastname');
+ $$userdata{$uname.':'.$udom}[$$idx{uname}] = $uname;
+ $$userdata{$uname.':'.$udom}[$$idx{udom}] = $udom;
+ return;
+}
+
+=pod
+
+=item * get_unprocessed_cgi($query,$possible_names)
+
+Modify the %env hash to contain unprocessed CGI form parameters held in
+$query. The parameters listed in $possible_names (an array reference),
+will be set in $env{'form.name'} if they do not already exist.
+
+Typically called with $ENV{'QUERY_STRING'} as the first parameter.
+$possible_names is an ref to an array of form element names. As an example:
+get_unprocessed_cgi($ENV{'QUERY_STRING'},['uname','udom']);
+will result in $env{'form.uname'} and $env{'form.udom'} being set.
+
+=cut
+
+sub get_unprocessed_cgi {
+ my ($query,$possible_names)= @_;
+ # $Apache::lonxml::debug=1;
+ foreach (split(/&/,$query)) {
+ my ($name, $value) = split(/=/,$_);
+ $name = &Apache::lonnet::unescape($name);
+ if (!defined($possible_names) || (grep {$_ eq $name} @$possible_names)) {
+ $value =~ tr/+/ /;
+ $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
+ unless (defined($env{'form.'.$name})) { &add_to_env('form.'.$name,$value) };
+ }
+ }
+}
+
+=pod
+
+=item * cacheheader()
+
+returns cache-controlling header code
+
+=cut
+
+sub cacheheader {
+ unless ($env{'request.method'} eq 'GET') { return ''; }
+ my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
+ my $output .='';
+ foreach my $type (sort(keys(%Types))) {
+ $Str .= ''.$Types{$type}." \n";
+ }
+ $Str .= " \n";
+ return $Str;
+}
+
+sub get_samples {
+ my ($records,$toget) = @_;
+ my @samples=({});
+ my $got=0;
+ foreach my $rec (@$records) {
+ my %temp = &record_sep($rec);
+ if (! grep(/\S/, values(%temp))) { next; }
+ if (%temp) {
+ $samples[$got]=\%temp;
+ $got++;
+ if ($got == $toget) { last; }
+ }
+ }
+ return \@samples;
+}
+
+######################################################
+######################################################
+
+=pod
+
+=item * csv_print_samples($r,$records)
+
+Prints a table of sample values from each column uploaded $r is an
+Apache Request ref, $records is an arrayref from
+&Apache::loncommon::upfile_record_sep
+
+=cut
+
+######################################################
+######################################################
+sub csv_print_samples {
+ my ($r,$records) = @_;
+ my $samples = &get_samples($records,3);
+
+ $r->print(&mt('Samples').'');
+ foreach (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
+ $r->print(''.&mt('Column [_1]',($_+1)).' '); }
+ $r->print(' ');
+ foreach my $hash (@$samples) {
+ $r->print('');
+ foreach (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
+ $r->print('');
+ if (defined($$hash{$_})) { $r->print($$hash{$_}); }
+ $r->print(' ');
+ }
+ $r->print(' ');
+ }
+ $r->print('
'.
+ ''.&mt('Attribute').' '.
+ ''.&mt('Column').' '."\n");
+ foreach (@$d) {
+ my ($value,$display,$defaultcol)=@{ $_ };
+ $r->print(''.$display.' ');
+
+ $r->print('');
+ $r->print('Column '.($_+1).' ');
+ }
+ $r->print(' '.
+ &mt('Field').' '.&mt('Samples').' ');
+ foreach my $option (@$d) {
+ my ($value,$display,$defaultcol)=@{ $option };
+ $r->print(''.
+ $display.' ');
+ }
+ $r->print(' ');
+ foreach my $line (0..2) {
+ if (defined($samples->[$line]{$key})) {
+ $r->print($samples->[$line]{$key}." '.$linktext.' ';
+}
+
+#######################################################
+#######################################################
+
+=pod
+
+=head1 Course Environment Routines
+
+=over 4
+
+=item &restore_course_settings
+
+=item &store_course_settings
+
+Restores/Store indicated form parameters from the course environment.
+Will not overwrite existing values of the form parameters.
+
+Inputs:
+a scalar describing the data (e.g. 'chart', 'problem_analysis')
+
+a hash ref describing the data to be stored. For example:
+
+%Save_Parameters = ('Status' => 'scalar',
+ 'chartoutputmode' => 'scalar',
+ 'chartoutputdata' => 'scalar',
+ 'Section' => 'array',
+ 'StudentData' => 'array',
+ 'Maps' => 'array');
+
+Returns: both routines return nothing
+
+=cut
+
+#######################################################
+#######################################################
+sub store_course_settings {
+ # save to the environment
+ # appenv the same items, just to be safe
+ my $courseid = $env{'request.course.id'};
+ my $udom = $env{'user.domain'};
+ my $uname = $env{'user.name'};
+ my ($prefix,$Settings) = @_;
+ my %SaveHash;
+ my %AppHash;
+ while (my ($setting,$type) = each(%$Settings)) {
+ my $basename = join('.','internal',$courseid,$prefix,$setting);
+ my $envname = 'environment.'.$basename;
+ if (exists($env{'form.'.$setting})) {
+ # Save this value away
+ if ($type eq 'scalar' &&
+ (! exists($env{$envname}) ||
+ $env{$envname} ne $env{'form.'.$setting})) {
+ $SaveHash{$basename} = $env{'form.'.$setting};
+ $AppHash{$envname} = $env{'form.'.$setting};
+ } elsif ($type eq 'array') {
+ my $stored_form;
+ if (ref($env{'form.'.$setting})) {
+ $stored_form = join(',',
+ map {
+ &Apache::lonnet::escape($_);
+ } sort(@{$env{'form.'.$setting}}));
+ } else {
+ $stored_form =
+ &Apache::lonnet::escape($env{'form.'.$setting});
+ }
+ # Determine if the array contents are the same.
+ if ($stored_form ne $env{$envname}) {
+ $SaveHash{$basename} = $stored_form;
+ $AppHash{$envname} = $stored_form;
+ }
+ }
+ }
+ }
+ my $put_result = &Apache::lonnet::put('environment',\%SaveHash,
+ $udom,$uname);
+ if ($put_result !~ /^(ok|delayed)/) {
+ &Apache::lonnet::logthis('unable to save form parameters, '.
+ 'got error:'.$put_result);
+ }
+ # Make sure these settings stick around in this session, too
+ &Apache::lonnet::appenv(%AppHash);
+ return;
+}
+
+sub restore_course_settings {
+ my $courseid = $env{'request.course.id'};
+ my ($prefix,$Settings) = @_;
+ while (my ($setting,$type) = each(%$Settings)) {
+ next if (exists($env{'form.'.$setting}));
+ my $envname = 'environment.internal.'.$courseid.'.'.$prefix.
+ '.'.$setting;
+ if (exists($env{$envname})) {
+ if ($type eq 'scalar') {
+ $env{'form.'.$setting} = $env{$envname};
+ } elsif ($type eq 'array') {
+ $env{'form.'.$setting} = [
+ map {
+ &Apache::lonnet::unescape($_);
+ } split(',',$env{$envname})
+ ];
+ }
+ }
+ }
+}
+
+############################################################
+############################################################
+
+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;
+}
+
+sub icon {
+ my ($file)=@_;
+ my $curfext = (split(/\./,$file))[-1];
+ my $iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/unknown.gif';
+ my $embstyle = &Apache::loncommon::fileembstyle($curfext);
+ if (!(!defined($embstyle) || $embstyle eq 'unk' || $embstyle eq 'hdn')) {
+ if (-e $Apache::lonnet::perlvar{'lonDocRoot'}.'/'.
+ $Apache::lonnet::perlvar{'lonIconsURL'}.'/'.
+ $curfext.".gif") {
+ $iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/'.
+ $curfext.".gif";
+ }
+ }
+ return &lonhttpdurl($iconname);
+}
+
+sub lonhttpdurl {
+ my ($url)=@_;
+ my $lonhttpd_port=$Apache::lonnet::perlvar{'lonhttpdPort'};
+ if (!defined($lonhttpd_port)) { $lonhttpd_port='8080'; }
+ return 'http://'.$ENV{'SERVER_NAME'}.':'.$lonhttpd_port.$url;
+}
+
+sub connection_aborted {
+ my ($r)=@_;
+ $r->print(" ");$r->rflush();
+ my $c = $r->connection;
+ return $c->aborted();
+}
+
+# Escapes strings that may have embedded 's that will be put into
+# strings as 'strings'.
+sub escape_single {
+ my ($input) = @_;
+ $input =~ s/\\/\\\\/g; # Escape the \'s..(must be first)>
+ $input =~ s/\'/\\\'/g; # Esacpe the 's....
+ return $input;
+}
+
+# Same as escape_single, but escape's "'s This
+# can be used for "strings"
+sub escape_double {
+ my ($input) = @_;
+ $input =~ s/\\/\\\\/g; # Escape the /'s..(must be first)>
+ $input =~ s/\"/\\\"/g; # Esacpe the "s....
+ return $input;
+}
+
+# Escapes the last element of a full URL.
+sub escape_url {
+ my ($url) = @_;
+ my @urlslices = split(/\//, $url,-1);
+ my $lastitem = &Apache::lonnet::escape(pop(@urlslices));
+ return join('/',@urlslices).'/'.$lastitem;
+}
+=pod
+
+=back
+
+=cut
+
1;
__END__;
+