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,$order)
Returns a string containing a element int multiple mode
Args:
$name - name of the element
$value - sclara or array ref of values that should already be selected
$size - number of rows long the select element is
$hash - the elements should be 'option' => 'shown text'
(shown text should already have been &mt())
$order - (optional) array ref of the order to show the elments in
=cut
#-------------------------------------------
sub multiple_select_form {
my ($name,$value,$size,$hash,$order)=@_;
my %selected = map { $_ => 1 } ref($value)?@{$value}:($value);
my $output='';
if (! defined($size)) {
$size = 4;
if (scalar(keys(%$hash))<4) {
$size = scalar(keys(%$hash));
}
}
$output.="\n";
my @order = ref($order) ? @$order
: sort(keys(%$hash));
foreach my $key (@order) {
$output.=''.$hash->{$key}." \n";
}
$output.=" \n";
return $output;
}
#-------------------------------------------
=pod
=item * select_form($defdom,$name,%hash)
Returns a string containing a form to
allow a user to select options from a hash option_name => displayed text.
See lonrights.pm for an example invocation and use.
=cut
#-------------------------------------------
sub select_form {
my ($def,$name,%hash) = @_;
my $selectform = "\n";
my @keys;
if (exists($hash{'select_form_order'})) {
@keys=@{$hash{'select_form_order'}};
} else {
@keys=sort(keys(%hash));
}
foreach (@keys) {
$selectform.="".&mt($hash{$_})." \n";
}
$selectform.=" ";
return $selectform;
}
sub gradeleveldescription {
my $gradelevel=shift;
my %gradelevels=(0 => 'Not specified',
1 => 'Grade 1',
2 => 'Grade 2',
3 => 'Grade 3',
4 => 'Grade 4',
5 => 'Grade 5',
6 => 'Grade 6',
7 => 'Grade 7',
8 => 'Grade 8',
9 => 'Grade 9',
10 => 'Grade 10',
11 => 'Grade 11',
12 => 'Grade 12',
13 => 'Grade 13',
14 => '100 Level',
15 => '200 Level',
16 => '300 Level',
17 => '400 Level',
18 => 'Graduate Level');
return &mt($gradelevels{$gradelevel});
}
sub select_level_form {
my ($deflevel,$name)=@_;
unless ($deflevel) { $deflevel=0; }
my $selectform = "\n";
for (my $i=0; $i<=18; $i++) {
$selectform.="".&gradeleveldescription($i)." \n";
}
$selectform.=" ";
return $selectform;
}
#-------------------------------------------
=pod
=item * select_dom_form($defdom,$name,$includeempty)
Returns a string containing a form to
allow a user to select the domain to preform an operation in.
See loncreateuser.pm for an example invocation and use.
If the $includeempty flag is set, it also includes an empty choice ("no domain
selected");
=cut
#-------------------------------------------
sub select_dom_form {
my ($defdom,$name,$includeempty) = @_;
my @domains = get_domains();
if ($includeempty) { @domains=('',@domains); }
my $selectdomain = "\n";
foreach (@domains) {
$selectdomain.="$_ \n";
}
$selectdomain.=" ";
return $selectdomain;
}
#-------------------------------------------
=pod
=item * get_library_servers($domain)
Returns a hash which contains keys like '103l3' and values like
'kirk.lite.msu.edu'. All of the keys will be for machines in the
given $domain.
=cut
#-------------------------------------------
sub get_library_servers {
my $domain = shift;
my %library_servers;
foreach (keys(%Apache::lonnet::libserv)) {
if ($Apache::lonnet::hostdom{$_} eq $domain) {
$library_servers{$_} = $Apache::lonnet::hostname{$_};
}
}
return %library_servers;
}
#-------------------------------------------
=pod
=item * home_server_option_list($domain)
returns a string which contains an list to be used in a
form input. See loncreateuser.pm for an example.
=cut
#-------------------------------------------
sub home_server_option_list {
my $domain = shift;
my %servers = &get_library_servers($domain);
my $result = '';
foreach (sort keys(%servers)) {
$result.=
''.$_.' '.$servers{$_}." \n";
}
return $result;
}
=pod
=back
=cut
###############################################################
## Decoding User Agent ##
###############################################################
=pod
=head1 Decoding the User Agent
=over 4
=item * &decode_user_agent()
Inputs: $r
Outputs:
=over 4
=item * $httpbrowser
=item * $clientbrowser
=item * $clientversion
=item * $clientmathml
=item * $clientunicode
=item * $clientos
=back
=back
=cut
###############################################################
###############################################################
sub decode_user_agent {
my ($r)=@_;
my @browsertype=split(/\&/,$Apache::lonnet::perlvar{"lonBrowsDet"});
my %mathcap=split(/\&/,$$Apache::lonnet::perlvar{"lonMathML"});
my $httpbrowser=$ENV{"HTTP_USER_AGENT"};
if (!$httpbrowser && $r) { $httpbrowser=$r->header_in('User-Agent'); }
my $clientbrowser='unknown';
my $clientversion='0';
my $clientmathml='';
my $clientunicode='0';
for (my $i=0;$i<=$#browsertype;$i++) {
my ($bname,$match,$notmatch,$vreg,$minv,$univ)=split(/\:/,$browsertype[$i]);
if (($httpbrowser=~/$match/i) && ($httpbrowser!~/$notmatch/i)) {
$clientbrowser=$bname;
$httpbrowser=~/$vreg/i;
$clientversion=$1;
$clientmathml=($clientversion>=$minv);
$clientunicode=($clientversion>=$univ);
}
}
my $clientos='unknown';
if (($httpbrowser=~/linux/i) ||
($httpbrowser=~/unix/i) ||
($httpbrowser=~/ux/i) ||
($httpbrowser=~/solaris/i)) { $clientos='unix'; }
if (($httpbrowser=~/vax/i) ||
($httpbrowser=~/vms/i)) { $clientos='vms'; }
if ($httpbrowser=~/next/i) { $clientos='next'; }
if (($httpbrowser=~/mac/i) ||
($httpbrowser=~/powerpc/i)) { $clientos='mac'; }
if ($httpbrowser=~/win/i) { $clientos='win'; }
if ($httpbrowser=~/embed/i) { $clientos='pda'; }
return ($httpbrowser,$clientbrowser,$clientversion,$clientmathml,
$clientunicode,$clientos,);
}
###############################################################
## Authentication changing form generation subroutines ##
###############################################################
##
## All of the authform_xxxxxxx subroutines take their inputs in a
## hash, and have reasonable default values.
##
## formname = the name given in the
ENDROLE
my $titleinfo = ''.$title.' ';
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.')';
}
# Explicit link to get inline menu
my $menu=' '.&mt('Switch to Inline Menu Mode').' ';
#
return(<
$upperleft
$messages
$titleinfo $dc_info $menu
$env{'environment.firstname'}
$env{'environment.middlename'}
$env{'environment.lastname'}
$env{'environment.generation'}
$role
$realm
ENDBODY
}
###############################################
###############################################
=pod
=back
=head1 HTML Helpers
=over 4
=item * &endbodytag()
Returns a uniform footer for LON-CAPA web pages.
Inputs: none
=back
=cut
sub endbodytag {
my $endbodytag='';
$endbodytag=&Apache::lontexconvert::jsMath_process()."\n".$endbodytag;
if ( exists( $env{'internal.head.redirect'} ) ) {
$endbodytag=
"".
&mt('Continue').' '.
$endbodytag;
}
return $endbodytag;
}
=pod
=over 4
=item * &headtag()
Returns a uniform footer for LON-CAPA web pages.
Inputs: $title - optional title for the head
$head_extra - optional extra HTML to put inside the
$args - optional arguments
force_register - if is true call registerurl so the remote is
informed
redirect - array ref of seconds before redirect occurs
url to redirect to
(side effect of setting
$env{'internal.head.redirect'} to the url
redirected too)
=back
=cut
sub headtag {
my ($title,$head_extra,$args) = @_;
my $result =
''.
&Apache::lonxml::fontsettings().
&Apache::lonhtmlcommon::htmlareaheaders();
if ($args->{'force_register'}) {
$result .= &Apache::lonmenu::registerurl(1);
}
if (ref($args->{'redirect'})) {
my ($time,$url) = @{$args->{'redirect'}};
$url = &Apache::lonenc::check_encrypt($url);
$env{'internal.head.redirect'} = $url;
$result.=<
ADDMETA
}
if (!defined($title)) {
$title = 'The LearningOnline Network with CAPA';
}
$result .= ' LON-CAPA '.&mt($title).' '.$head_extra;
return $result;
}
=pod
=over 4
=item * &endheadtag()
Returns a uniform for LON-CAPA web pages.
Inputs: none
=back
=cut
sub endheadtag {
return '';
}
=pod
=over 4
=item * &head()
Returns a uniform complete .. section for LON-CAPA web pages.
Inputs: $title - optional title for the page
$head_extra - optional extra HTML to put inside the
=back
=cut
sub head {
my ($title,$head_extra,$args) = @_;
return &headtag($title,$head_extra,$args).&endheadtag();
}
=pod
=over 4
=item * &start_page()
Returns a complete .. section for LON-CAPA web pages.
Inputs: $title - optional title for the page
$head_extra - optional extra HTML to incude inside the
$args - additional optional args supported are:
only_body -> is true will set &bodytag() onlybodytag
arg on
no_nav_bar -> is true will set &bodytag() notopbar arg on
add_entries -> additional attributes to add to the
domain -> force to color decorate a page for a
specific domain
function -> force usage of a specific rolish color
scheme
redirect -> see &headtag()
bgcolor -> override the default page bg color
js_ready -> return a string ready for being used in
a javascript writeln
html_encode -> return a string ready for being used in
a html attribute
force_register -> if is true will turn on the &bodytag()
$forcereg arg
body_title -> alternate text to use instead of $title
in the title box that appears, this text
is not auto translated like the $title is
=back
=cut
sub start_page {
my ($title,$head_extra,$args) = @_;
#&Apache::lonnet::logthis("start_page ".join(':',caller(0)));
my %head_args;
foreach my $arg ('redirect','force_register') {
if (defined($args->{$arg})) {
$head_args{$arg} = $args->{$arg};
}
}
$env{'internal.start_page'}++;
my $result =
&Apache::lonxml::xmlbegin().
&headtag($title,$head_extra,\%head_args).&endheadtag().
&bodytag($title,
$args->{'function'}, $args->{'add_entries'},
$args->{'only_body'}, $args->{'domain'},
$args->{'force_register'}, $args->{'body_title'},
$args->{'no_nav_bar'}, $args->{'bgcolor'});
if ($args->{'js_ready'}) {
$result = &js_ready($result);
}
if ($args->{'html_encode'}) {
$result = &html_encode($result);
}
return $result;
}
=pod
=over 4
=item * &head()
Returns a complete section for LON-CAPA web pages.
Inputs: $args - additional optional args supported are:
js_ready -> return a string ready for being used in
a javascript writeln
html_encode -> return a string ready for being used in
a html attribute
=back
=cut
sub end_page {
my ($args) = @_;
#&Apache::lonnet::logthis("end_page ".join(':',caller(0)));
$env{'internal.end_page'}++;
my $result = &endbodytag()."\n";
if ($args->{'js_ready'}) {
$result = &js_ready($result);
}
if ($args->{'html_encode'}) {
$result = &html_encode($result);
}
return $result;
}
sub html_encode {
my ($result) = @_;
$result = &HTML::Entities::encode($result,'<>&"');
return $result;
}
sub js_ready {
my ($result) = @_;
$result =~ s/[\n\r]/ /xmsg;
$result =~ s/\\/\\\\/xmsg;
$result =~ s/'/\\'/xmsg;
$result =~ s{}{}xmsg;
return $result;
}
sub validate_page {
if ( exists($env{'internal.start_page'})
&& $env{'internal.start_page'} > 1) {
&Apache::lonnet::logthis('start_page called multiple times '.
$env{'internal.start_page'}.' '.
$ENV{'request.filename'});
}
if ( exists($env{'internal.end_page'})
&& $env{'internal.end_page'} > 1) {
&Apache::lonnet::logthis('end_page called multiple times '.
$env{'internal.end_page'}.' '.
$env{'request.filename'});
}
if ( exists($env{'internal.start_page'})
&& ! exists($env{'internal.end_page'})) {
&Apache::lonnet::logthis('start_page called without end_page '.
$env{'request.filename'});
}
if ( ! exists($env{'internal.start_page'})
&& exists($env{'internal.end_page'})) {
&Apache::lonnet::logthis('end_page called without start_page'.
$env{'request.filename'});
}
}
sub simple_error_page {
my ($r,$title,$msg) = @_;
my $page =
&Apache::loncommon::start_page($title).
&mt($msg).
&Apache::loncommon::end_page();
if (ref($r)) {
$r->print($page);
return;
}
return $page;
}
###############################################
=pod
=over 4
=item get_users_function
Used by &bodytag to determine the current users primary role.
Returns either 'student','coordinator','admin', or 'author'.
=cut
###############################################
sub get_users_function {
my $function = 'student';
if ($env{'request.role'}=~/^(cc|in|ta|ep)/) {
$function='coordinator';
}
if ($env{'request.role'}=~/^(su|dc|ad|li)/) {
$function='admin';
}
if (($env{'request.role'}=~/^(au|ca)/) ||
($ENV{'REQUEST_URI'}=~/^(\/priv|\~)/)) {
$function='author';
}
return $function;
}
###############################################
=pod
=item check_user_status
Determines current status of supplied role for a
specific user. Roles can be active, previous or future.
Inputs:
user's domain, user's username, course's domain,
course's number, optional section/group.
Outputs:
role status: active, previous or future.
=cut
sub check_user_status {
my ($udom,$uname,$cdom,$crs,$role,$secgrp) = @_;
my %userinfo = &Apache::lonnet::dump('roles',$udom,$uname);
my @uroles = keys %userinfo;
my $srchstr;
my $active_chk = 'none';
if (@uroles > 0) {
if (($role eq 'cc') || ($secgrp eq '') || (!defined($secgrp))) {
$srchstr = '/'.$cdom.'/'.$crs.'_'.$role;
} else {
$srchstr = '/'.$cdom.'/'.$crs.'/'.$secgrp.'_'.$role; }
if (grep/^$srchstr$/,@uroles) {
my $role_end = 0;
my $role_start = 0;
$active_chk = 'active';
if ($userinfo{$srchstr} =~ m/^($role)_(\d+)/) {
$role_end = $2;
if ($userinfo{$srchstr} =~ m/^($role)_($role_end)_(\d+)$/) {
$role_start = $3;
}
}
if ($role_start > 0) {
if (time < $role_start) {
$active_chk = 'future';
}
}
if ($role_end > 0) {
if (time > $role_end) {
$active_chk = 'previous';
}
}
}
}
return $active_chk;
}
###############################################
=pod
=item get_sections
Determines all the sections for a course including
sections with students and sections containing other roles.
Incoming parameters: domain, course number, reference to
section hash (keys to be section/group IDs), reference to
array containing roles for which sections should be gathered
(optional). If the fourth argument is undefined, sections
are gathered for any role.
Returns number of sections.
=cut
###############################################
sub get_sections {
my ($cdom,$cnum,$sectioncount,$possible_roles) = @_;
if (!($cdom && $cnum)) { return 0; }
my $numsections = 0;
if (!defined($possible_roles) || (grep/^st$/,@$possible_roles)) {
my ($classlist) = &Apache::loncoursedata::get_classlist($cdom,$cnum);
my $sec_index = &Apache::loncoursedata::CL_SECTION();
my $status_index = &Apache::loncoursedata::CL_STATUS();
while (my ($student,$data) = each %$classlist) {
my ($section,$status) = ($data->[$sec_index],
$data->[$status_index]);
unless ($section eq '-1' || $section =~ /^\s*$/) {
if (!defined($$sectioncount{$section})) { $numsections++; }
$$sectioncount{$section}++;
}
}
}
my %courseroles = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum);
foreach my $user (sort(keys(%courseroles))) {
if ($user !~ /^(\w{2})/) { next; }
my ($role) = ($user =~ /^(\w{2})/);
if ($possible_roles && !(grep(/^$role$/,@$possible_roles))) { next; }
my $section;
if ($role eq 'cr' &&
$user =~ m-^$role/[^/]*/[^/]*/[^/]*:[^:]*:[^:]*:(\w+)-) {
$section=$1;
}
if ($user =~ /^$role:[^:]*:[^:]*:(\w+)/) { $section=$1; }
if (!defined($section) || $section eq '-1') { next; }
if (!defined($$sectioncount{$section})) { $numsections++; }
$$sectioncount{$section}++;
}
return $numsections;
}
###############################################
=pod
=item coursegroups
Retrieve information about groups in a course,
Input:
1. Reference to hash to populate with group information.
2. Optional course domain
3. Optional course number
4. Optional group name
Course domain and number will be taken from user's
environment if not supplied. Optional group name will'
be passed to lonnet::get_coursegroups() as a regexp to
use in the call to the dump function.
Output
Returns number of groups in the course (subject to the
optional group name filter).
Side effects:
Populates the referenced curr_groups hash, with key,
value pairs. Keys are group names, corresponding values
are scalars containing group information in XML. This
can be sent to &get_group_settings() to be parsed.
=cut
###############################################
sub coursegroups {
my ($curr_groups,$cdom,$cnum,$group) = @_;
my $numgroups;
if (!defined($cdom) || !defined($cnum)) {
my $cid = $env{'request.course.id'};
$cdom = $env{'course.'.$cid.'.domain'};
$cnum = $env{'course.'.$cid.'.num'};
}
%{$curr_groups} = &Apache::lonnet::get_coursegroups($cdom,$cnum,$group);
my ($tmp) = keys(%{$curr_groups});
if ($tmp=~/^error:/) {
unless ($tmp eq 'error: 2 tie(GDBM) Failed while attempting dump') {
&logthis('Error retrieving groups: '.$tmp.' in '.$cnum.':'.
$cdom);
}
$numgroups = 0;
} else {
$numgroups = keys(%{$curr_groups});
}
return $numgroups;
}
###############################################
=pod
=item get_group_settings
Uses TokeParser to extract group information from the
XML used to describe course groups.
Input:
Scalar containing XML - as retrieved from &coursegroups().
Output:
Hash containing group information as key=values for (a), and
hash of hashes for (b)
Keys (in two categories):
(a) groupname, creator, creation, modified, startdate,enddate.
Corresponding values are name of the group, creator of the group
(username:domain), UNIX time for date group was created, and
settings were last modified, and default start and end access
times for group members.
(b) functions returned in hash of hashes.
Outer hash key is functions.
Inner hash keys are chat,discussion,email,files,homepage,roster.
Corresponding values are either on or off, depending on
whether this type of functionality is available for the group.
=cut
###############################################
sub get_group_settings {
my ($groupinfo)=@_;
my $parser=HTML::TokeParser->new(\$groupinfo);
my $token;
my $tool = '';
my $role = '';
my %content=();
while ($token=$parser->get_token) {
if ($token->[0] eq 'S') {
my $entry=$token->[1];
if ($entry eq 'functions' || $entry eq 'autosec') {
%{$content{$entry}} = ();
$tool = $entry;
} elsif ($entry eq 'role') {
if ($tool eq 'autosec') {
$role = $token->[2]{id};
}
} else {
my $value=$parser->get_text('/'.$entry);
if ($entry eq 'name') {
if ($tool eq 'functions') {
my $function = $token->[2]{id};
$content{$tool}{$function} = $value;
}
} elsif ($entry eq 'groupname') {
$content{$entry}=&Apache::lonnet::unescape($value);
} elsif (($entry eq 'roles') || ($entry eq 'types') ||
($entry eq 'sectionpick') || ($entry eq 'defpriv')) {
push(@{$content{$entry}},$value);
} elsif ($entry eq 'section') {
if ($tool eq 'autosec' && $role ne '') {
push(@{$content{$tool}{$role}},$value);
}
} else {
$content{$entry}=$value;
}
}
} elsif ($token->[0] eq 'E') {
if ($token->[1] eq 'functions' || $token->[1] eq 'autosec') {
$tool = '';
} elsif ($token->[1] eq 'role') {
$role = '';
}
}
}
return %content;
}
sub check_group_access {
my ($group) = @_;
my $access = 1;
my $now = time;
my ($start,$end) = split(/\./,$env{'user.role.gr/'.$env{'request.course,id'}.'/'.$group});
if (($end!=0) && ($end<$now)) { $access = 0; }
if (($start!=0) && ($start>$now)) { $access=0; }
return $access;
}
###############################################
=pod
=item get_course_users
Retrieves usernames:domains for users in the specified course
with specific role(s), and access status.
Incoming parameters:
1. course domain
2. course number
3. access status: users must have - either active,
previous, future, or all.
4. reference to array of permissible roles
5. reference to array of section restrictions (optional)
6. reference to results object (hash of hashes).
7. reference to optional userdata hash
Keys of top level hash are roles.
Keys of inner hashes are username:domain, with
values set to access type.
Optional userdata hash returns an array with arguments in the
same order as loncoursedata::get_classlist() for student data.
Entries for end, start, section and status are blank because
of the possibility of multiple values for non-student roles.
=cut
###############################################
sub get_course_users {
my ($cdom,$cnum,$types,$roles,$sections,$users,$userdata) = @_;
my %idx = ();
$idx{udom} = &Apache::loncoursedata::CL_SDOM();
$idx{uname} = &Apache::loncoursedata::CL_SNAME();
$idx{end} = &Apache::loncoursedata::CL_END();
$idx{start} = &Apache::loncoursedata::CL_START();
$idx{id} = &Apache::loncoursedata::CL_ID();
$idx{section} = &Apache::loncoursedata::CL_SECTION();
$idx{fullname} = &Apache::loncoursedata::CL_FULLNAME();
$idx{status} = &Apache::loncoursedata::CL_STATUS();
if (grep(/^st$/,@{$roles})) {
my ($classlist,$keylist)=&Apache::loncoursedata::get_classlist($cdom,$cnum);
my $now = time;
foreach my $student (keys(%{$classlist})) {
my $match = 0;
if ((ref($sections) eq 'ARRAY') && (@{$sections} > 0)) {
unless(grep(/^\Q$$classlist{$student}[$idx{section}]\E$/,
@{$sections})) {
next;
}
}
if (defined($$types{'active'})) {
if ($$classlist{$student}[$idx{status}] eq 'Active') {
push(@{$$users{st}{$student}},'active');
$match = 1;
}
}
if (defined($$types{'previous'})) {
if ($$classlist{$student}[$idx{end}] <= $now) {
push(@{$$users{st}{$student}},'previous');
$match = 1;
}
}
if (defined($$types{'future'})) {
if (($$classlist{$student}[$idx{start}] > $now) && ($$classlist{$student}[$idx{end}] > $now) || ($$classlist{$student}[$idx{end}] == 0) || ($$classlist{$student}[$idx{end}] eq '')) {
push(@{$$users{st}{$student}},'future');
$match = 1;
}
}
if ($match && defined($userdata)) {
$$userdata{$student} = $$classlist{$student};
}
}
}
if ((@{$roles} > 0) && (@{$roles} ne "st")) {
my @coursepersonnel = &Apache::lonnet::getkeys('nohist_userroles',$cdom,$cnum);
foreach my $person (@coursepersonnel) {
my $match = 0;
my ($role,$user) = ($person =~ /^([^:]*):([^:]+:[^:]+)/);
$user =~ s/:$//;
if (($role) && (grep(/^\Q$role\E$/,@{$roles}))) {
my ($uname,$udom,$usec) = split(/:/,$user);
if ($usec ne '' && (ref($sections) eq 'ARRAY') &&
@{$sections} > 0) {
unless(grep(/^\Q$usec\E$/,@{$sections})) {
next;
}
}
if ($uname ne '' && $udom ne '') {
my $status = &check_user_status($udom,$uname,$cdom,$cnum,$role);
foreach my $type (keys(%{$types})) {
if ($status eq $type) {
@{$$users{$role}{$user}} = $type;
$match = 1;
}
}
if ($match && defined($userdata) &&
!exists($$userdata{$uname.':'.$udom})) {
&get_user_info($udom,$uname,\%idx,$userdata);
}
}
}
}
if (grep(/^ow$/,@{$roles})) {
if ((defined($cdom)) && (defined($cnum))) {
my %csettings = &Apache::lonnet::get('environment',['internal.courseowner'],$cdom,$cnum);
if ( defined($csettings{'internal.courseowner'}) ) {
my $owner = $csettings{'internal.courseowner'};
@{$$users{'ow'}{$owner.':'.$cdom}} = 'any';
if (defined($userdata) &&
!exists($$userdata{$owner.':'.$cdom})) {
&get_user_info($cdom,$owner,\%idx,$userdata);
}
}
}
}
}
return;
}
sub get_user_info {
my ($udom,$uname,$idx,$userdata) = @_;
$$userdata{$uname.':'.$udom}[$$idx{fullname}] =
&plainname($uname,$udom,'lastname');
$$userdata{$uname.':'.$udom}[$$idx{uname}] = $uname;
$$userdata{$uname.':'.$udom}[$$idx{udom}] = $udom;
return;
}
###############################################
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";
}
}
}
#
# Digested POSTed values
#
# Remember the way this was originally done (GET or POST)
#
$env{'request.method'}=$ENV{'REQUEST_METHOD'};
#
# There may also be stuff in the query string
# Tell subsequent handlers that this was GET, not POST, so they can access query string.
# Also, unset POSTed content length to cover all tracks.
#
# This does not work, because M_GET is not defined (if it's defined, it is just 0).
# Commenting out for now ... not sure if harm is done.
# $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 ($r) {
# Note that printout.pl calls this with undef for $r.
&no_cache($r);
}
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;
}
sub get_samples {
my ($records,$toget) = @_;
my @samples=({});
my $got=0;
foreach my $rec (@$records) {
my %temp = &record_sep($rec);
if (! grep(/\S/, values(%temp))) { next; }
if (%temp) {
$samples[$got]=\%temp;
$got++;
if ($got == $toget) { last; }
}
}
return \@samples;
}
######################################################
######################################################
=pod
=item * csv_print_samples($r,$records)
Prints a table of sample values from each column uploaded $r is an
Apache Request ref, $records is an arrayref from
&Apache::loncommon::upfile_record_sep
=cut
######################################################
######################################################
sub csv_print_samples {
my ($r,$records) = @_;
my $samples = &get_samples($records,3);
$r->print(&mt('Samples').'');
foreach (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
$r->print(''.&mt('Column [_1]',($_+1)).' '); }
$r->print(' ');
foreach my $hash (@$samples) {
$r->print('');
foreach (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
$r->print('');
if (defined($$hash{$_})) { $r->print($$hash{$_}); }
$r->print(' ');
}
$r->print(' ');
}
$r->print('
'."\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 $samples = &get_samples($records,1);
$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(%{ $samples->[0] }))) {
$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 $i=0;
#
my $samples = &get_samples($records,3);
$r->print(''.
&mt('Field').' '.&mt('Samples').' ');
foreach my $key (sort(keys(%{ $samples->[0] }))) {
$r->print('');
foreach my $option (@$d) {
my ($value,$display,$defaultcol)=@{ $option };
$r->print(''.
$display.' ');
}
$r->print(' ');
foreach my $line (0..2) {
if (defined($samples->[$line]{$key})) {
$r->print($samples->[$line]{$key}." \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 $udom = $env{'user.domain'};
my $uname = $env{'user.name'};
my ($prefix,$Settings) = @_;
my %SaveHash;
my %AppHash;
while (my ($setting,$type) = each(%$Settings)) {
my $basename = join('.','internal',$courseid,$prefix,$setting);
my $envname = 'environment.'.$basename;
if (exists($env{'form.'.$setting})) {
# Save this value away
if ($type eq 'scalar' &&
(! exists($env{$envname}) ||
$env{$envname} ne $env{'form.'.$setting})) {
$SaveHash{$basename} = $env{'form.'.$setting};
$AppHash{$envname} = $env{'form.'.$setting};
} elsif ($type eq 'array') {
my $stored_form;
if (ref($env{'form.'.$setting})) {
$stored_form = join(',',
map {
&Apache::lonnet::escape($_);
} sort(@{$env{'form.'.$setting}}));
} else {
$stored_form =
&Apache::lonnet::escape($env{'form.'.$setting});
}
# Determine if the array contents are the same.
if ($stored_form ne $env{$envname}) {
$SaveHash{$basename} = $stored_form;
$AppHash{$envname} = $stored_form;
}
}
}
}
my $put_result = &Apache::lonnet::put('environment',\%SaveHash,
$udom,$uname);
if ($put_result !~ /^(ok|delayed)/) {
&Apache::lonnet::logthis('unable to save form parameters, '.
'got error:'.$put_result);
}
# Make sure these settings stick around in this session, too
&Apache::lonnet::appenv(%AppHash);
return;
}
sub restore_course_settings {
my $courseid = $env{'request.course.id'};
my ($prefix,$Settings) = @_;
while (my ($setting,$type) = each(%$Settings)) {
next if (exists($env{'form.'.$setting}));
my $envname = 'environment.internal.'.$courseid.'.'.$prefix.
'.'.$setting;
if (exists($env{$envname})) {
if ($type eq 'scalar') {
$env{'form.'.$setting} = $env{$envname};
} elsif ($type eq 'array') {
$env{'form.'.$setting} = [
map {
&Apache::lonnet::unescape($_);
} split(',',$env{$envname})
];
}
}
}
}
############################################################
############################################################
sub propath {
my ($udom,$uname)=@_;
$udom=~s/\W//g;
$uname=~s/\W//g;
my $subdir=$uname.'__';
$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
my $proname="$Apache::lonnet::perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
return $proname;
}
sub icon {
my ($file)=@_;
my $curfext = (split(/\./,$file))[-1];
my $iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/unknown.gif';
my $embstyle = &Apache::loncommon::fileembstyle($curfext);
if (!(!defined($embstyle) || $embstyle eq 'unk' || $embstyle eq 'hdn')) {
if (-e $Apache::lonnet::perlvar{'lonDocRoot'}.'/'.
$Apache::lonnet::perlvar{'lonIconsURL'}.'/'.
$curfext.".gif") {
$iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/'.
$curfext.".gif";
}
}
return &lonhttpdurl($iconname);
}
sub lonhttpdurl {
my ($url)=@_;
my $lonhttpd_port=$Apache::lonnet::perlvar{'lonhttpdPort'};
if (!defined($lonhttpd_port)) { $lonhttpd_port='8080'; }
return 'http://'.$ENV{'SERVER_NAME'}.':'.$lonhttpd_port.$url;
}
sub connection_aborted {
my ($r)=@_;
$r->print(" ");$r->rflush();
my $c = $r->connection;
return $c->aborted();
}
# Escapes strings that may have embedded 's that will be put into
# strings as 'strings'.
sub escape_single {
my ($input) = @_;
$input =~ s/\\/\\\\/g; # Escape the \'s..(must be first)>
$input =~ s/\'/\\\'/g; # Esacpe the 's....
return $input;
}
# Same as escape_single, but escape's "'s This
# can be used for "strings"
sub escape_double {
my ($input) = @_;
$input =~ s/\\/\\\\/g; # Escape the /'s..(must be first)>
$input =~ s/\"/\\\"/g; # Esacpe the "s....
return $input;
}
# Escapes the last element of a full URL.
sub escape_url {
my ($url) = @_;
my @urlslices = split(/\//, $url,-1);
my $lastitem = &Apache::lonnet::escape(pop(@urlslices));
return join('/',@urlslices).'/'.$lastitem;
}
=pod
=back
=cut
1;
__END__;