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.=" ".&mt($hashref->{$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.=" ".&mt($select2{$value})." \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 ";
+ }
+
+ # Add the graphic
+ my $title = &mt('Online Help');
+ my $helpicon=&lonhttpdurl("/adm/help/gif/smallHelp.gif");
+ $template .= <<"ENDTEMPLATE";
+
+ENDTEMPLATE
+ if ($text ne '') { $template.='
' };
+ 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 ";
+ }
+ my $helpicon=&lonhttpdurl("/adm/lonIcons/helpgateway.gif");
+ $template .= <<"ENDTEMPLATE";
+
+
+ENDTEMPLATE
+ if ($component_help) {
+ if (!$text) {
+ $template=&help_open_topic($component_help,undef,$stayOnPage,
+ $width,$height).' '.$template;
+ } else {
+ my $help_text;
+ $help_text=&Apache::lonnet::unescape($topic);
+ $template=''.
+ &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 ";
+ }
+
+ # Add the graphic
+ my $title = &mt('Report a Bug');
+ my $bugicon=&lonhttpdurl("/adm/lonMisc/smallBug.gif");
+ $template .= <<"ENDTEMPLATE";
+
+ENDTEMPLATE
+ if ($text ne '') { $template.='
' };
+ 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 ";
+ }
+
+ # Add the graphic
+ my $title = &mt('View the FAQ');
+ my $faqicon=&lonhttpdurl("/adm/lonMisc/smallFAQ.gif");
+ $template .= <<"ENDTEMPLATE";
+
+ENDTEMPLATE
+ if ($text ne '') { $template.='
' };
+ return $template;
+
+}
+
+###############################################################
+###############################################################
+
+=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 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->{'date'} = $workbook->add_format(num_format=>
+ 'mm/dd/yyyy hh:mm:ss');
+ return $format;
+}
+
+###############################################################
+###############################################################
+
+=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 ";
+ } else {
+ return "$origContent ";
+ }
+}
+
+=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);
+ }
+}
+
+sub multiple_select_form {
+ my ($name,$value,$size,%hash)=@_;
+ 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";
+ foreach (sort(keys(%hash))) {
+ $output.=''.$hash{$_}." \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 @browsertype=split(/\&/,$Apache::lonnet::perlvar{"lonBrowsDet"});
+ my %mathcap=split(/\&/,$$Apache::lonnet::perlvar{"lonMathML"});
+ my $httpbrowser=$ENV{"HTTP_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.' ';
+ if ($customtitle) {
+ $titleinfo = $customtitle;
+ }
+ if ($ENV{'request.state'} eq 'construct') {
+ my ($uname,$thisdisfn)=
+ ($ENV{'request.filename'} =~ m|^/home/([^/]+)/public_html/(.*)|);
+ my $formaction='/priv/'.$uname.'/'.$thisdisfn;
+ $formaction=~s/\/+/\//g;
+ $titleinfo = ''
+ .&Apache::lonmenu::constspaceform();
+
+ &Apache::lonhtmlcommon::store_recent('construct',$formaction,$formaction);
+ if ($thisdisfn!~m|/$|) { $forcereg=1; }
+ }
+
+ return $bodytag.&Apache::lonmenu::menubuttons($forcereg,'web',
+ $forcereg).
+ ''.$titleinfo.' '.$roleinfo.'
';
+ }
+
+#
+# Top frame rendering, Remote is up
+#
+ my $titleinfo = ' '.$title.' ';
+ if ($customtitle) {
+ $titleinfo = $customtitle;
+ }
+ return(<
+
+$upperleft
+$messages
+
+
+
+$titleinfo
+
+
+ $ENV{'environment.firstname'}
+ $ENV{'environment.middlename'}
+ $ENV{'environment.lastname'}
+ $ENV{'environment.generation'}
+
+
+
+
+$role
+
+
+$realm
+
+ENDBODY
+}
+
+###############################################
+
+=pod
+
+=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 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) = @_;
+ my $cid = $cdom.'_'.$cnum;
+ my $numsections = 0;
+ if ($cdom && $cnum) {
+ if (!defined($possible_roles) || (grep/^st$/,@$possible_roles)) {
+ my ($classlist) = &Apache::loncoursedata::get_classlist($cid,$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 '' || $section =~ /^\s*$/) {
+ if (!defined($$sectioncount{$section})) {
+ $$sectioncount{$section} = 1;
+ $numsections ++;
+ } else {
+ $$sectioncount{$section} ++;
+ }
+ }
+ }
+ }
+ my %courseroles = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum);
+ foreach my $user (sort keys %courseroles) {
+ if ($user =~ /^(\w{2})/) {
+ my $role = $1;
+ if (!defined($possible_roles) || (grep/^$role$/,@$possible_roles)) {
+ if ($role eq 'cr') {
+ if ($user =~ m-^$role/[^/]*/[^/]*/[^/]*:[^:]*:[^:]*:(\w+)-) {
+ if (!defined($$sectioncount{$1})) {
+ $$sectioncount{$1} = 1;
+ $numsections ++;
+ } else {
+ $$sectioncount{$1} ++;
+ }
+ }
+ }
+ if ($user =~ /^$role:[^:]*:[^:]*:(\w+)/) {
+ if (!defined($$sectioncount{$1})) {
+ $$sectioncount{$1} = 1;
+ $numsections ++;
+ } else {
+ $$sectioncount{$1} ++;
+ }
+ }
+ }
+ }
+ }
+ }
+ return $numsections;
+}
+
+
+sub get_posted_cgi {
+ my $r=shift;
+
+ my $buffer;
+
+ $r->read($buffer,$r->header_in('Content-length'),0);
+ unless ($buffer=~/^(\-+\w+)\s+Content\-Disposition\:\s*form\-data/si) {
+ my @pairs=split(/&/,$buffer);
+ my $pair;
+ foreach $pair (@pairs) {
+ my ($name,$value) = split(/=/,$pair);
+ $value =~ tr/+/ /;
+ $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
+ $name =~ tr/+/ /;
+ $name =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
+ &add_to_env("form.$name",$value);
+ }
+ } else {
+ my $contentsep=$1;
+ my @lines = split (/\n/,$buffer);
+ my $name='';
+ my $value='';
+ my $fname='';
+ my $fmime='';
+ my $i;
+ for ($i=0;$i<=$#lines;$i++) {
+ if ($lines[$i]=~/^$contentsep/) {
+ if ($name) {
+ chomp($value);
+ if ($fname) {
+ $ENV{"form.$name.filename"}=$fname;
+ $ENV{"form.$name.mimetype"}=$fmime;
+ } else {
+ $value=~s/\s+$//s;
+ }
+ &add_to_env("form.$name",$value);
+ }
+ if ($i<$#lines) {
+ $i++;
+ $lines[$i]=~
+ /Content\-Disposition\:\s*form\-data\;\s*name\=\"([^\"]+)\"/i;
+ $name=$1;
+ $value='';
+ if ($lines[$i]=~/filename\=\"([^\"]+)\"/i) {
+ $fname=$1;
+ if
+ ($lines[$i+1]=~/Content\-Type\:\s*([\w\-\/]+)/i) {
+ $fmime=$1;
+ $i++;
+ } else {
+ $fmime='';
+ }
+ } else {
+ $fname='';
+ $fmime='';
+ }
+ $i++;
+ }
+ } else {
+ $value.=$lines[$i]."\n";
+ }
+ }
+ }
+ $ENV{'request.method'}=$ENV{'REQUEST_METHOD'};
+ $r->method_number(M_GET);
+ $r->method('GET');
+ $r->headers_in->unset('Content-length');
+}
+
+=pod
+
+=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;
+ &Apache::lonxml::debug("Seting :$name: to :$value:");
+ 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 .='
+
+ ';
+ return $output;
+}
+
+=pod
+
+=item * no_cache($r)
+
+specifies header code to not have cache
+
+=cut
+
+sub no_cache {
+ my ($r) = @_;
+ if ($ENV{'REQUEST_METHOD'} ne 'GET' &&
+ $ENV{'request.method'} ne 'GET') { return ''; }
+ my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime(time));
+ $r->no_cache(1);
+ $r->header_out("Expires" => $date);
+ $r->header_out("Pragma" => "no-cache");
+}
+
+sub content_type {
+ my ($r,$type,$charset) = @_;
+ unless ($charset) {
+ $charset=&Apache::lonlocal::current_encoding;
+ }
+ if ($charset) { $type.='; charset='.$charset; }
+ if ($r) {
+ $r->content_type($type);
+ } else {
+ print("Content-type: $type\n\n");
+ }
+}
+
+=pod
+
+=item * add_to_env($name,$value)
+
+adds $name to the %ENV hash with value
+$value, if $name already exists, the entry is converted to an array
+reference and $value is added to the array.
+
+=cut
+
+sub add_to_env {
+ my ($name,$value)=@_;
+ if (defined($ENV{$name})) {
+ if (ref($ENV{$name})) {
+ #already have multiple values
+ push(@{ $ENV{$name} },$value);
+ } else {
+ #first time seeing multiple values, convert hash entry to an arrayref
+ my $first=$ENV{$name};
+ undef($ENV{$name});
+ push(@{ $ENV{$name} },$first,$value);
+ }
+ } else {
+ $ENV{$name}=$value;
+ }
+}
+
+=pod
+
+=item * get_env_multiple($name)
+
+gets $name from the %ENV hash, it seemlessly handles the cases where multiple
+values may be defined and end up as an array ref.
+
+returns an array of values
+
+=cut
+
+sub get_env_multiple {
+ my ($name) = @_;
+ my @values;
+ if (defined($ENV{$name})) {
+ # exists is it an array
+ if (ref($ENV{$name})) {
+ @values=@{ $ENV{$name} };
+ } else {
+ $values[0]=$ENV{$name};
+ }
+ }
+ return(@values);
+}
+
+
+=pod
+
+=back
+
+=head1 CSV Upload/Handling functions
+
+=over 4
+
+=item * upfile_store($r)
+
+Store uploaded file, $r should be the HTTP Request object,
+needs $ENV{'form.upfile'}
+returns $datatoken to be put into hidden field
+
+=cut
+
+sub upfile_store {
+ my $r=shift;
+ $ENV{'form.upfile'}=~s/\r/\n/gs;
+ $ENV{'form.upfile'}=~s/\f/\n/gs;
+ $ENV{'form.upfile'}=~s/\n+/\n/gs;
+ $ENV{'form.upfile'}=~s/\n+$//gs;
+
+ my $datatoken=$ENV{'user.name'}.'_'.$ENV{'user.domain'}.
+ '_enroll_'.$ENV{'request.course.id'}.'_'.time.'_'.$$;
+ {
+ my $datafile = $r->dir_config('lonDaemons').
+ '/tmp/'.$datatoken.'.tmp';
+ if ( open(my $fh,">$datafile") ) {
+ print $fh $ENV{'form.upfile'};
+ close($fh);
+ }
+ }
+ return $datatoken;
+}
+
+=pod
+
+=item * load_tmp_file($r)
+
+Load uploaded file from tmp, $r should be the HTTP Request object,
+needs $ENV{'form.datatoken'},
+sets $ENV{'form.upfile'} to the contents of the file
+
+=cut
+
+sub load_tmp_file {
+ my $r=shift;
+ my @studentdata=();
+ {
+ my $studentfile = $r->dir_config('lonDaemons').
+ '/tmp/'.$ENV{'form.datatoken'}.'.tmp';
+ if ( open(my $fh,"<$studentfile") ) {
+ @studentdata=<$fh>;
+ close($fh);
+ }
+ }
+ $ENV{'form.upfile'}=join('',@studentdata);
+}
+
+=pod
+
+=item * upfile_record_sep()
+
+Separate uploaded file into records
+returns array of records,
+needs $ENV{'form.upfile'} and $ENV{'form.upfiletype'}
+
+=cut
+
+sub upfile_record_sep {
+ if ($ENV{'form.upfiletype'} eq 'xml') {
+ } else {
+ return split(/\n/,$ENV{'form.upfile'});
+ }
+}
+
+=pod
+
+=item * record_sep($record)
+
+Separate a record into fields $record should be an item from the upfile_record_sep(), needs $ENV{'form.upfiletype'}
+
+=cut
+
+sub record_sep {
+ my $record=shift;
+ my %components=();
+ if ($ENV{'form.upfiletype'} eq 'xml') {
+ } elsif ($ENV{'form.upfiletype'} eq 'space') {
+ my $i=0;
+ foreach (split(/\s+/,$record)) {
+ my $field=$_;
+ $field=~s/^(\"|\')//;
+ $field=~s/(\"|\')$//;
+ $components{$i}=$field;
+ $i++;
+ }
+ } elsif ($ENV{'form.upfiletype'} eq 'tab') {
+ my $i=0;
+ foreach (split(/\t/,$record)) {
+ my $field=$_;
+ $field=~s/^(\"|\')//;
+ $field=~s/(\"|\')$//;
+ $components{$i}=$field;
+ $i++;
+ }
+ } else {
+ my @allfields=split(/\,/,$record);
+ my $i=0;
+ my $j;
+ for ($j=0;$j<=$#allfields;$j++) {
+ my $field=$allfields[$j];
+ if ($field=~/^\s*(\"|\')/) {
+ my $delimiter=$1;
+ while (($field!~/$delimiter$/) && ($j<$#allfields)) {
+ $j++;
+ $field.=','.$allfields[$j];
+ }
+ $field=~s/^\s*$delimiter//;
+ $field=~s/$delimiter\s*$//;
+ }
+ $components{$i}=$field;
+ $i++;
+ }
+ }
+ return %components;
+}
+
+######################################################
+######################################################
+
+=pod
+
+=item * upfile_select_html()
+
+Return HTML code to select a file from the users machine and specify
+the file type.
+
+=cut
+
+######################################################
+######################################################
+sub upfile_select_html {
+ my %Types = (
+ csv => &mt('CSV (comma separated values, spreadsheet)'),
+ space => &mt('Space separated'),
+ tab => &mt('Tabulator separated'),
+# xml => &mt('HTML/XML'),
+ );
+ my $Str = ' '.
+ ' Type: ';
+ foreach my $type (sort(keys(%Types))) {
+ $Str .= ''.$Types{$type}." \n";
+ }
+ $Str .= " \n";
+ return $Str;
+}
+
+######################################################
+######################################################
+
+=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 (%sone,%stwo,%sthree);
+ %sone=&record_sep($$records[0]);
+ if (defined($$records[1])) {%stwo=&record_sep($$records[1]);}
+ if (defined($$records[2])) {%sthree=&record_sep($$records[2]);}
+ #
+ $r->print(&mt('Samples').'');
+ foreach (sort({$a <=> $b} keys(%sone))) {
+ $r->print(''.&mt('Column [_1]',($_+1)).' '); }
+ $r->print(' ');
+ foreach my $hash (\%sone,\%stwo,\%sthree) {
+ $r->print('');
+ foreach (sort({$a <=> $b} keys(%sone))) {
+ $r->print('');
+ if (defined($$hash{$_})) { $r->print($$hash{$_}); }
+ $r->print(' ');
+ }
+ $r->print(' ');
+ }
+ $r->print('
'."\n");
+}
+
+######################################################
+######################################################
+
+=pod
+
+=item * csv_print_select_table($r,$records,$d)
+
+Prints a table to create associations between values and table columns.
+
+$r is an Apache Request ref,
+$records is an arrayref from &Apache::loncommon::upfile_record_sep,
+$d is an array of 2 element arrays (internal name, displayed name,defaultcol)
+
+=cut
+
+######################################################
+######################################################
+sub csv_print_select_table {
+ my ($r,$records,$d) = @_;
+ my $i=0;my %sone;
+ %sone=&record_sep($$records[0]);
+ $r->print(&mt('Associate columns with student attributes.')."\n".
+ ''.
+ ''.&mt('Attribute').' '.
+ ''.&mt('Column').' '."\n");
+ foreach (@$d) {
+ my ($value,$display,$defaultcol)=@{ $_ };
+ $r->print(''.$display.' ');
+
+ $r->print('');
+ $r->print(' ');
+ foreach (sort({$a <=> $b} keys(%sone))) {
+ $r->print('Column '.($_+1).' ');
+ }
+ $r->print(' '."\n");
+ $i++;
+ }
+ $i--;
+ return $i;
+}
+
+######################################################
+######################################################
+
+=pod
+
+=item * csv_samples_select_table($r,$records,$d)
+
+Prints a table of sample values from the upload and can make associate samples to internal names.
+
+$r is an Apache Request ref,
+$records is an arrayref from &Apache::loncommon::upfile_record_sep,
+$d is an array of 2 element arrays (internal name, displayed name)
+
+=cut
+
+######################################################
+######################################################
+sub csv_samples_select_table {
+ my ($r,$records,$d) = @_;
+ my %sone; my %stwo; my %sthree;
+ my $i=0;
+ #
+ $r->print(''.
+ &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('');
+ foreach (@$d) {
+ my ($value,$display,$defaultcol)=@{ $_ };
+ $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(' ');
+ $i++;
+ }
+ $i--;
+ return($i);
+}
+
+######################################################
+######################################################
+
+=pod
+
+=item clean_excel_name($name)
+
+Returns a replacement for $name which does not contain any illegal characters.
+
+=cut
+
+######################################################
+######################################################
+sub clean_excel_name {
+ my ($name) = @_;
+ $name =~ s/[:\*\?\/\\]//g;
+ if (length($name) > 31) {
+ $name = substr($name,0,31);
+ }
+ return $name;
+}
+
+=pod
+
+=item * check_if_partid_hidden($id,$symb,$udom,$uname)
+
+Returns either 1 or undef
+
+1 if the part is to be hidden, undef if it is to be shown
+
+Arguments are:
+
+$id the id of the part to be checked
+$symb, optional the symb of the resource to check
+$udom, optional the domain of the user to check for
+$uname, optional the username of the user to check for
+
+=cut
+
+sub check_if_partid_hidden {
+ my ($id,$symb,$udom,$uname) = @_;
+ my $hiddenparts=&Apache::lonnet::EXT('resource.0.hiddenparts',
+ $symb,$udom,$uname);
+ my $truth=1;
+ #if the string starts with !, then the list is the list to show not hide
+ if ($hiddenparts=~s/^\s*!//) { $truth=undef; }
+ my @hiddenlist=split(/,/,$hiddenparts);
+ foreach my $checkid (@hiddenlist) {
+ if ($checkid =~ /^\s*\Q$id\E\s*$/) { return $truth; }
+ }
+ return !$truth;
+}
+
+
+############################################################
+############################################################
+
+=pod
+
+=back
+
+=head1 cgi-bin script and graphing routines
+
+=over 4
+
+=item get_cgi_id
+
+Inputs: none
+
+Returns an id which can be used to pass environment variables
+to various cgi-bin scripts. These environment variables will
+be removed from the users environment after a given time by
+the routine &Apache::lonnet::transfer_profile_to_env.
+
+=cut
+
+############################################################
+############################################################
+my $uniq=0;
+sub get_cgi_id {
+ $uniq=($uniq+1)%100000;
+ return (time.'_'.$uniq);
+}
+
+############################################################
+############################################################
+
+=pod
+
+=item DrawBarGraph
+
+Facilitates the plotting of data in a (stacked) bar graph.
+Puts plot definition data into the users environment in order for
+graph.png to plot it. Returns an tag for the plot.
+The bars on the plot are labeled '1','2',...,'n'.
+
+Inputs:
+
+=over 4
+
+=item $Title: string, the title of the plot
+
+=item $xlabel: string, text describing the X-axis of the plot
+
+=item $ylabel: string, text describing the Y-axis of the plot
+
+=item $Max: scalar, the maximum Y value to use in the plot
+If $Max is < any data point, the graph will not be rendered.
+
+=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.
+
+=back
+
+Returns:
+
+An tag which references graph.png and the appropriate identifying
+information for the plot.
+
+=cut
+
+############################################################
+############################################################
+sub DrawBarGraph {
+ my ($Title,$xlabel,$ylabel,$Max,$colors,$labels,@Values)=@_;
+ #
+ if (! defined($colors)) {
+ $colors = ['#33ff00',
+ '#0033cc', '#990000', '#aaaa66', '#663399', '#ff9933',
+ '#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) {
+ next if (! ref($array));
+ $ValuesHash{$id.'.data.'.$NumSets++} =
+ join(',',@$array);
+ }
+ #
+ my ($height,$width,$xskip,$bar_width) = (200,120,1,15);
+ 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;
+ } elsif ($NumBars <= 25) {
+ $width = 120+$NumBars*11;
+ $xskip = 5;
+ $bar_width = 8;
+ } elsif ($NumBars <= 50) {
+ $width = 120+$NumBars*8;
+ $xskip = 5;
+ $bar_width = 4;
+ } else {
+ $width = 120+$NumBars*8;
+ $xskip = 5;
+ $bar_width = 4;
+ }
+ #
+ $Max = 1 if ($Max < 1);
+ if ( int($Max) < $Max ) {
+ $Max++;
+ $Max = int($Max);
+ }
+ $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.'.y_max_value'} = $Max;
+ $ValuesHash{$id.'.NumBars'} = $NumBars;
+ $ValuesHash{$id.'.NumSets'} = $NumSets;
+ $ValuesHash{$id.'.PlotType'} = 'bar';
+ $ValuesHash{$id.'.Colors'} = join(',',@{$colors});
+ $ValuesHash{$id.'.height'} = $height;
+ $ValuesHash{$id.'.width'} = $width;
+ $ValuesHash{$id.'.xskip'} = $xskip;
+ $ValuesHash{$id.'.bar_width'} = $bar_width;
+ $ValuesHash{$id.'.labels'} = join(',',@Labels);
+ #
+ # Deal with other parameters
+ while (my ($key,$value) = each(%$extra_settings)) {
+ $ValuesHash{$id.'.'.$key} = $value;
+ }
+ #
+ &Apache::lonnet::appenv(%ValuesHash);
+ return ' ';
+}
+
+############################################################
+############################################################
+
+=pod
+
+=item DrawXYGraph
+
+Facilitates the plotting of data in an XY graph.
+Puts plot definition data into the users environment in order for
+graph.png to plot it. Returns an tag for the plot.
+
+Inputs:
+
+=over 4
+
+=item $Title: string, the title of the plot
+
+=item $xlabel: string, text describing the X-axis of the plot
+
+=item $ylabel: string, text describing the Y-axis of the plot
+
+=item $Max: scalar, the maximum Y value to use in the plot
+If $Max is < any data point, the graph will not be rendered.
+
+=item $colors: Array ref containing the hex color codes for the data to be
+plotted in. If undefined, default values will be used.
+
+=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 separate curve.
+
+=item %Values: hash indicating or overriding any default values which are
+passed to graph.png.
+Possible values are: width, xskip, x_ticks, x_tick_offset, among others.
+
+=back
+
+Returns:
+
+An tag which references graph.png and the appropriate identifying
+information for the plot.
+
+=cut
+
+############################################################
+############################################################
+sub DrawXYGraph {
+ my ($Title,$xlabel,$ylabel,$Max,$colors,$Xlabels,$Ydata,%Values)=@_;
+ #
+ # Create the identifier for the graph
+ my $identifier = &get_cgi_id();
+ my $id = 'cgi.'.$identifier;
+ #
+ $Title = '' if (! defined($Title));
+ $xlabel = '' if (! defined($xlabel));
+ $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.'.y_max_value'=> $Max,
+ $id.'.labels' => join(',',@$Xlabels),
+ $id.'.PlotType' => 'XY',
+ );
+ #
+ if (defined($colors) && ref($colors) eq 'ARRAY') {
+ $ValuesHash{$id.'.Colors'} = join(',',@{$colors});
+ }
+ #
+ if (! ref($Ydata) || ref($Ydata) ne 'ARRAY') {
+ return '';
+ }
+ my $NumSets=1;
+ foreach my $array (@{$Ydata}){
+ next if (! ref($array));
+ $ValuesHash{$id.'.data.'.$NumSets++} = join(',',@$array);
+ }
+ $ValuesHash{$id.'.NumSets'} = $NumSets-1;
+ #
+ # Deal with other parameters
+ while (my ($key,$value) = each(%Values)) {
+ $ValuesHash{$id.'.'.$key} = $value;
+ }
+ #
+ &Apache::lonnet::appenv(%ValuesHash);
+ return ' ';
+}
+
+############################################################
+############################################################
+
+=pod
+
+=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
+graph.png to plot it. Returns an tag for the plot.
+
+Inputs:
+
+=over 4
+
+=item $Title: string, the title of the plot
+
+=item $xlabel: string, text describing the X-axis of the plot
+
+=item $ylabel: string, text describing the Y-axis of the plot
+
+=item $colors: Array ref containing the hex color codes for the data to be
+plotted in. If undefined, default values will be used.
+
+=item $Xlabels: Array ref containing the labels to be used for the X-axis.
+
+=item $Ydata1: The first data set
+
+=item $Min1: The minimum value of the left Y-axis
+
+=item $Max1: The maximum value of the left Y-axis
+
+=item $Ydata2: The second data set
+
+=item $Min2: The minimum value of the right Y-axis
+
+=item $Max2: The maximum value of the left Y-axis
+
+=item %Values: hash indicating or overriding any default values which are
+passed to graph.png.
+Possible values are: width, xskip, x_ticks, x_tick_offset, among others.
+
+=back
+
+Returns:
+
+An tag which references graph.png and the appropriate identifying
+information for the plot.
+
+=cut
+
+############################################################
+############################################################
+sub DrawXYYGraph {
+ my ($Title,$xlabel,$ylabel,$colors,$Xlabels,$Ydata1,$Min1,$Max1,
+ $Ydata2,$Min2,$Max2,%Values)=@_;
+ #
+ # Create the identifier for the graph
+ my $identifier = &get_cgi_id();
+ my $id = 'cgi.'.$identifier;
+ #
+ $Title = '' if (! defined($Title));
+ $xlabel = '' if (! defined($xlabel));
+ $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.'.labels' => join(',',@$Xlabels),
+ $id.'.PlotType' => 'XY',
+ $id.'.NumSets' => 2,
+ $id.'.two_axes' => 1,
+ $id.'.y1_max_value' => $Max1,
+ $id.'.y1_min_value' => $Min1,
+ $id.'.y2_max_value' => $Max2,
+ $id.'.y2_min_value' => $Min2,
+ );
+ #
+ if (defined($colors) && ref($colors) eq 'ARRAY') {
+ $ValuesHash{$id.'.Colors'} = join(',',@{$colors});
+ }
+ #
+ if (! ref($Ydata1) || ref($Ydata1) ne 'ARRAY' ||
+ ! ref($Ydata2) || ref($Ydata2) ne 'ARRAY'){
+ return '';
+ }
+ my $NumSets=1;
+ foreach my $array ($Ydata1,$Ydata2){
+ next if (! ref($array));
+ $ValuesHash{$id.'.data.'.$NumSets++} = join(',',@$array);
+ }
+ #
+ # Deal with other parameters
+ while (my ($key,$value) = each(%Values)) {
+ $ValuesHash{$id.'.'.$key} = $value;
+ }
+ #
+ &Apache::lonnet::appenv(%ValuesHash);
+ return ' ';
+}
+
+############################################################
+############################################################
+
+=pod
+
+=back
+
+=head1 Statistics helper routines?
+
+Bad place for them but what the hell.
+
+=over 4
+
+=item &chartlink
+
+Returns a link to the chart for a specific student.
+
+Inputs:
+
+=over 4
+
+=item $linktext: The text of the link
+
+=item $sname: The students username
+
+=item $sdomain: The students domain
+
+=back
+
+=back
+
+=cut
+
+############################################################
+############################################################
+sub chartlink {
+ my ($linktext, $sname, $sdomain) = @_;
+ my $link = ''.$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 $coursedom = $ENV{'course.'.$courseid.'.domain'};
+ my ($prefix,$Settings) = @_;
+ my %SaveHash;
+ my %AppHash;
+ while (my ($setting,$type) = each(%$Settings)) {
+ my $basename = 'internal.'.$prefix.'.'.$setting;
+ my $envname = 'course.'.$courseid.'.'.$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,
+ $coursedom,
+ $ENV{'course.'.$courseid.'.num'});
+ 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 = 'course.'.$courseid.'.internal.'.$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 $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);
+ my $lastitem = &Apache::lonnet::escape(pop(@urlslices));
+ return join('/',@urlslices).'/'.$lastitem;
+}
+=pod
+
+=back
+
+=cut
+
1;
__END__;
+
500 Internal Server Error
Internal Server Error
The server encountered an internal error or
misconfiguration and was unable to complete
your request.
Please contact the server administrator at
root@localhost to inform them of the time this error occurred,
and the actions you performed just before this error.
More information about this error may be available
in the server error log.