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 $nothing=&Apache::lonhtmlcommon::javascript_nothing();
my $html=&Apache::lonxml::xmlbegin();
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 * 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
=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)
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())
=cut
#-------------------------------------------
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 ($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.' ';
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;
unless ($customtitle) { #this is for resources; directories have customtitle, and crumbs and select recent are created in lonpubdir.pm
my $parentpath = '';
my $lastitem = '';
if ($thisdisfn =~ m-(.+/)([^/]*)$-) {
$parentpath = $1;
$lastitem = $2;
} else {
$lastitem = $thisdisfn;
}
$titleinfo = &Apache::loncommon::help_open_menu('','','','',3,'Authoring').
'Construction Space : '.
''
.&Apache::lonmenu::constspaceform();
}
$forcereg=1;
}
my $titletable = ''.
''.
$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.' ';
if ($customtitle) {
$titleinfo = $customtitle;
}
#
# Extra info if you are the DC
my $dc_info = '';
if ($env{'user.adv'} && exists($env{'user.role.dc./'.
$env{'course.'.$env{'request.course.id'}.
'.domain'}.'/'})) {
my $cid = $env{'request.course.id'};
$dc_info.= $cid.' '.$env{'course.'.$cid.'.internal.coursecode'};
$dc_info = '('.$dc_info.')';
}
#
return(<
$upperleft
$messages
$titleinfo $dc_info
$env{'environment.firstname'}
$env{'environment.middlename'}
$env{'environment.lastname'}
$env{'environment.generation'}
$role
$realm
ENDBODY
}
###############################################
###############################################
=pod
=back
=head1 HTTP Helpers
=over 4
=item * &endbodytag()
Returns a uniform footer for LON-CAPA web pages.
Inputs:
=over 4
=back
Returns: A uniform footer for LON-CAPA web pages.
=cut
sub endbodytag {
my $endbodytag='';
$endbodytag=&Apache::lontexconvert::jsMath_process()."\n".$endbodytag;
return $endbodytag;
}
###############################################
=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 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 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 results object (hash of hashes).
Keys of top level hash are roles.
Keys of inner hashes are username:domain, with
values set to access type.
=cut
###############################################
sub get_course_users {
my ($cdom,$cnum,$types,$roles,$users) = @_;
if (grep/^st$/,@{$roles}) {
my $statusidx = &Apache::loncoursedata::CL_STATUS();
my $startidx = &Apache::loncoursedata::CL_START();
my $endidx = &Apache::loncoursedata::CL_END();
my ($classlist,$keylist)=&Apache::loncoursedata::get_classlist($cdom,$cnum);
my $now = time;
foreach my $student (keys(%{$classlist})) {
if (defined($$types{'active'})) {
if ($$classlist{$student}[$statusidx] eq 'Active') {
push(@{$$users{st}{$student}},'active');
}
}
if (defined($$types{'previous'})) {
if ($$classlist{$student}[$endidx] <= $now) {
push(@{$$users{st}{$student}},'previous');
}
}
if (defined($$types{'future'})) {
if (($$classlist{$student}[$startidx] > $now) && ($$classlist{$student}[$endidx] > $now) || ($$classlist{$student}[$endidx] == 0) || ($$classlist{$student}[$endidx] eq '')) {
push(@{$$users{st}{$student}},'future');
}
}
}
}
if ((@{$roles} > 0) && (@{$roles} ne "st")) {
my @coursepersonnel = &Apache::lonnet::getkeys('nohist_userroles',$cdom,$cnum);
foreach my $person (@coursepersonnel) {
my ($role,$user) = ($person =~ /^([^:]*):([^:]+:[^:]+)/);
$user =~ s/:$//;
if (($role) && (grep(/^$role$/,@{$roles}))) {
my ($uname,$udom) = split(/:/,$user);
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;
}
}
}
}
}
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';
}
}
}
}
return;
}
###############################################
sub get_posted_cgi {
my $r=shift;
my $buffer;
if ($r->header_in('Content-length')) {
$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;
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) = @_;
if ($env{'browser.mathml'} && $type eq 'text/html') { $type='text/xml'; }
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 {
my @records;
foreach my $line (split(/\n/,$env{'form.upfile'})) {
if ($line=~/^\s*$/) { next; }
push(@records,$line);
}
return @records;
}
}
=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 takeleft {
my $index=shift;
return substr('0000'.$index,-4,4);
}
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{&takeleft($i)}=$field;
$i++;
}
} elsif ($env{'form.upfiletype'} eq 'tab') {
my $i=0;
foreach (split(/\t/,$record)) {
my $field=$_;
$field=~s/^(\"|\')//;
$field=~s/(\"|\')$//;
$components{&takeleft($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{&takeleft($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.
=item If the final element of @Values is a hash reference the key/value
pairs will be added to the graph definition.
=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 &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__;