--- loncom/interface/loncommon.pm 2005/03/10 00:21:48 1.255
+++ loncom/interface/loncommon.pm 2006/04/14 20:16:02 1.337
@@ -1,7 +1,7 @@
# The LearningOnline Network with CAPA
# a pile of common routines
#
-# $Id: loncommon.pm,v 1.255 2005/03/10 00:21:48 matthew Exp $
+# $Id: loncommon.pm,v 1.337 2006/04/14 20:16:02 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -55,13 +55,14 @@ redundancy from other modules and increa
package Apache::loncommon;
use strict;
-use Apache::lonnet();
+use Apache::lonnet;
use GDBM_File;
use POSIX qw(strftime mktime);
-use Apache::Constants qw(:common :http :methods);
use Apache::lonmenu();
use Apache::lonlocal;
use HTML::Entities;
+use Apache::lonhtmlcommon();
+use Apache::loncoursedata();
my $readit;
@@ -152,19 +153,20 @@ BEGIN {
my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';
opendir(DIR,$designdir);
while ($filename=readdir(DIR)) {
+ if ($filename!~/\.tab$/) { next; }
my ($domain)=($filename=~/^(\w+)\./);
- {
- my $designfile = $designdir.'/'.$filename;
- if ( open (my $fh,"<$designfile") ) {
- while (<$fh>) {
- next if /^\#/;
- chomp;
- my ($key,$val)=(split(/\=/,$_));
- if ($val) { $designhash{$domain.'.'.$key}=$val; }
- }
- close($fh);
- }
- }
+ {
+ my $designfile = $designdir.'/'.$filename;
+ if ( open (my $fh,"<$designfile") ) {
+ while (<$fh>) {
+ next if /^\#/;
+ chomp;
+ my ($key,$val)=(split(/\=/,$_));
+ if ($val) { $designhash{$domain.'.'.$key}=$val; }
+ }
+ close($fh);
+ }
+ }
}
closedir(DIR);
@@ -311,8 +313,8 @@ END
}
sub lastresurl {
- if ($ENV{'environment.lastresurl'}) {
- return $ENV{'environment.lastresurl'}
+ if ($env{'environment.lastresurl'}) {
+ return $env{'environment.lastresurl'}
} else {
return '/res';
}
@@ -329,9 +331,12 @@ sub storeresurl {
sub studentbrowser_javascript {
unless (
- (($ENV{'request.course.id'}) &&
- (&Apache::lonnet::allowed('srm',$ENV{'request.course.id'})))
- || ($ENV{'request.role'}=~/^(au|dc|su)/)
+ (($env{'request.course.id'}) &&
+ (&Apache::lonnet::allowed('srm',$env{'request.course.id'})
+ || &Apache::lonnet::allowed('srm',$env{'request.course.id'}.
+ '/'.$env{'request.course.sec'})
+ ))
+ || ($env{'request.role'}=~/^(au|dc|su)/)
) { return ''; }
return (<<'ENDSTDBRW');
'."\n".
- ''."\n";
- }
+
+ $bodytag .= &Apache::lontexconvert::init_math_support();
my $upperleft=' ';
- if ($bodyonly) {
+ if ($bodyonly
+ || ($env{'request.state'} eq 'construct'
+ && $env{'environment.remote'} ne 'off' )) {
return $bodytag;
- } elsif ($ENV{'browser.interface'} eq 'textual') {
+ } elsif ($env{'browser.interface'} eq 'textual') {
# Accessibility
- return $bodytag.&Apache::lonmenu::menubuttons($forcereg,'web',
- $forcereg).
- '
LON-CAPA: '.$title.' ';
- } elsif ($ENV{'environment.remote'} eq 'off') {
+ $bodytag.=&Apache::lonmenu::menubuttons($forcereg,$forcereg);
+ if (!$hidetitle) {
+ $bodytag.='LON-CAPA: '.$title.' ';
+ }
+ return $bodytag;
+ } elsif ($env{'environment.remote'} eq 'off') {
# No Remote
my $roleinfo=(<
- $ENV{'environment.firstname'}
- $ENV{'environment.middlename'}
- $ENV{'environment.lastname'}
- $ENV{'environment.generation'}
+ $env{'environment.firstname'}
+ $env{'environment.middlename'}
+ $env{'environment.lastname'}
+ $env{'environment.generation'}
$role
@@ -2717,9 +2852,9 @@ ENDROLE
$titleinfo = $customtitle;
}
- if ($ENV{'request.state'} eq 'construct') {
+ if ($env{'request.state'} eq 'construct') {
my ($uname,$thisdisfn)=
- ($ENV{'request.filename'} =~ m|^/home/([^/]+)/public_html/(.*)|);
+ ($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
@@ -2743,15 +2878,28 @@ ENDROLE
}
$forcereg=1;
}
- my $titletable = ''.
- ''.
+ ' '.
$titleinfo.' '.$roleinfo.'
';
- if ($ENV{'request.state'} eq 'construct') {
- $bodytag .= &Apache::lonmenu::menubuttons($forcereg,'web',$forcereg,$titletable);
+ }
+ if ($env{'request.state'} eq 'construct') {
+ if ($notopbar) {
+ $bodytag .= $titletable;
+ } else {
+ $bodytag .= &Apache::lonmenu::menubuttons($forcereg,$forcereg,
+ $titletable);
+ }
} else {
- $bodytag .= &Apache::lonmenu::menubuttons($forcereg,'web',$forcereg).
+ if ($notopbar) {
+ $bodytag .= $titletable;
+ } else {
+ $bodytag .= &Apache::lonmenu::menubuttons($forcereg,$forcereg).
$titletable;
+ }
}
return $bodytag;
}
@@ -2766,14 +2914,19 @@ ENDROLE
#
# 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'}.
+ 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'};
+ 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').' ';
#
+ if ($hidetitle) {
+ return $bodytag;
+ }
return(<
@@ -2783,13 +2936,13 @@ $upperleft
-$titleinfo $dc_info
-
+$titleinfo $dc_info $menu
+
- $ENV{'environment.firstname'}
- $ENV{'environment.middlename'}
- $ENV{'environment.lastname'}
- $ENV{'environment.generation'}
+ $env{'environment.firstname'}
+ $env{'environment.middlename'}
+ $env{'environment.lastname'}
+ $env{'environment.generation'}
@@ -2802,6 +2955,29 @@ $titleinfo $dc_info
ENDBODY
}
+sub make_attr_string {
+ my ($register,$attr_ref) = @_;
+
+ if ($attr_ref && !ref($attr_ref)) {
+ die("addentries Must be a hash ref ".
+ join(':',caller(1))." ".
+ join(':',caller(0))." ");
+ }
+
+ if ($register) {
+ $attr_ref->{'onload'} = &Apache::lonmenu::loadevents().
+ $attr_ref->{'onload'};
+ $attr_ref->{'onunload'} = &Apache::lonmenu::unloadevents().
+ $attr_ref->{'onunload'};
+ }
+ my $attr_string;
+ foreach my $attr (keys(%$attr_ref)) {
+ $attr_string .= " $attr=\"".$attr_ref->{$attr}.'" ';
+ }
+ return $attr_string;
+}
+
+
###############################################
###############################################
@@ -2809,7 +2985,7 @@ ENDBODY
=back
-=head1 HTTP Helpers
+=head1 HTML Helpers
=over 4
@@ -2817,29 +2993,297 @@ ENDBODY
Returns a uniform footer for LON-CAPA web pages.
-Inputs:
-
-=over 4
+Inputs: none
=back
-Returns: A uniform footer for LON-CAPA web pages.
-
=cut
sub endbodytag {
my $endbodytag=' section for LON-CAPA web pages.
+
+Inputs: $title - optional title for the page
+ $head_extra - optional extra HTML to incude inside the
+ $args - additional optional args supported are:
+ only_body -> is true will set &bodytag() onlybodytag
+ arg on
+ no_nav_bar -> is true will set &bodytag() notopbar arg on
+ add_entries -> additional attributes to add to the
+ domain -> force to color decorate a page for a
+ specific domain
+ function -> force usage of a specific rolish color
+ scheme
+ redirect -> see &headtag()
+ bgcolor -> override the default page bg color
+ js_ready -> return a string ready for being used in
+ a javascript writeln
+ html_encode -> return a string ready for being used in
+ a html attribute
+ force_register -> if is true will turn on the &bodytag()
+ $forcereg arg
+ body_title -> alternate text to use instead of $title
+ in the title box that appears, this text
+ is not auto translated like the $title is
+ frameset -> if true will start with a
+ rather than
+
+=back
+
+=cut
+
+sub start_page {
+ my ($title,$head_extra,$args) = @_;
+ #&Apache::lonnet::logthis("start_page ".join(':',caller(0)));
+ my %head_args;
+ foreach my $arg ('redirect','force_register') {
+ if (defined($args->{$arg})) {
+ $head_args{$arg} = $args->{$arg};
+ }
+ }
+
+ $env{'internal.start_page'}++;
+ my $result =
+ &Apache::lonxml::xmlbegin().
+ &headtag($title,$head_extra,\%head_args).&endheadtag();
+ if ($args->{'frameset'}) {
+ my $attr_string = &make_attr_string($args->{'force_register'},
+ $args->{'add_entries'});
+ $result .= "\n\n";
+ } else {
+ $result .=
+ &bodytag($title,
+ $args->{'function'}, $args->{'add_entries'},
+ $args->{'only_body'}, $args->{'domain'},
+ $args->{'force_register'}, $args->{'body_title'},
+ $args->{'no_nav_bar'}, $args->{'bgcolor'});
+ }
+ if ($args->{'js_ready'}) {
+ $result = &js_ready($result);
+ }
+ if ($args->{'html_encode'}) {
+ $result = &html_encode($result);
+ }
+ return $result;
+}
+
+
+=pod
+
+=over 4
+
+=item * &head()
+
+Returns a complete section for LON-CAPA web pages.
+
+Inputs: $args - additional optional args supported are:
+ js_ready -> return a string ready for being used in
+ a javascript writeln
+ html_encode -> return a string ready for being used in
+ a html attribute
+ frameset -> if true will start with a
+ rather than
+=back
+
+=cut
+
+sub end_page {
+ my ($args) = @_;
+ #&Apache::lonnet::logthis("end_page ".join(':',caller(0)));
+ $env{'internal.end_page'}++;
+ my $result;
+ if ($args->{'discussion'}) {
+ my ($target,$parser);
+ if (ref($args->{'discussion'})) {
+ ($target,$parser) =($args->{'discussion'}{'target'},
+ $args->{'discussion'}{'parser'});
+ }
+ $result .= &Apache::lonxml::xmlend($target,$parser);
+ }
+
+ if ($args->{'frameset'}) {
+ $result .= ' ';
+ } else {
+ $result .= &endbodytag();
+ }
+ $result .= "\n";
+
+ if ($args->{'js_ready'}) {
+ $result = &js_ready($result);
+ }
+
+ if ($args->{'html_encode'}) {
+ $result = &html_encode($result);
+ }
+
+ return $result;
+}
+
+sub html_encode {
+ my ($result) = @_;
+
+ $result = &HTML::Entities::encode($result,'<>&"');
+
+ return $result;
+}
+sub js_ready {
+ my ($result) = @_;
+
+ $result =~ s/[\n\r]/ /xmsg;
+ $result =~ s/\\/\\\\/xmsg;
+ $result =~ s/'/\\'/xmsg;
+ $result =~ s{}{}xmsg;
+
+ return $result;
+}
+
+sub validate_page {
+ if ( exists($env{'internal.start_page'})
+ && $env{'internal.start_page'} > 1) {
+ &Apache::lonnet::logthis('start_page called multiple times '.
+ $env{'internal.start_page'}.' '.
+ $ENV{'request.filename'});
+ }
+ if ( exists($env{'internal.end_page'})
+ && $env{'internal.end_page'} > 1) {
+ &Apache::lonnet::logthis('end_page called multiple times '.
+ $env{'internal.end_page'}.' '.
+ $env{'request.filename'});
+ }
+ if ( exists($env{'internal.start_page'})
+ && ! exists($env{'internal.end_page'})) {
+ &Apache::lonnet::logthis('start_page called without end_page '.
+ $env{'request.filename'});
+ }
+ if ( ! exists($env{'internal.start_page'})
+ && exists($env{'internal.end_page'})) {
+ &Apache::lonnet::logthis('end_page called without start_page'.
+ $env{'request.filename'});
+ }
+}
+
+sub simple_error_page {
+ my ($r,$title,$msg) = @_;
+ my $page =
+ &Apache::loncommon::start_page($title).
+ &mt($msg).
+ &Apache::loncommon::end_page();
+ if (ref($r)) {
+ $r->print($page);
+ return;
+ }
+ return $page;
+}
###############################################
=pod
+=over 4
+
=item get_users_function
Used by &bodytag to determine the current users primary role.
@@ -2850,13 +3294,13 @@ Returns either 'student','coordinator','
###############################################
sub get_users_function {
my $function = 'student';
- if ($ENV{'request.role'}=~/^(cc|in|ta|ep)/) {
+ if ($env{'request.role'}=~/^(cc|in|ta|ep)/) {
$function='coordinator';
}
- if ($ENV{'request.role'}=~/^(su|dc|ad|li)/) {
+ if ($env{'request.role'}=~/^(su|dc|ad|li)/) {
$function='admin';
}
- if (($ENV{'request.role'}=~/^(au|ca)/) ||
+ if (($env{'request.role'}=~/^(au|ca)/) ||
($ENV{'REQUEST_URI'}=~/^(\/priv|\~)/)) {
$function='author';
}
@@ -2867,6 +3311,60 @@ sub get_users_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
@@ -2885,11 +3383,10 @@ Returns number of sections.
sub get_sections {
my ($cdom,$cnum,$sectioncount,$possible_roles) = @_;
if (!($cdom && $cnum)) { return 0; }
- my $cid = $cdom.'_'.$cnum;
my $numsections = 0;
if (!defined($possible_roles) || (grep/^st$/,@$possible_roles)) {
- my ($classlist) = &Apache::loncoursedata::get_classlist($cid,$cdom,$cnum);
+ 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) {
@@ -2919,88 +3416,298 @@ sub get_sections {
return $numsections;
}
+###############################################
+
+=pod
+
+=item coursegroups
-sub get_posted_cgi {
- my $r=shift;
+Retrieve information about groups in a course,
- my $buffer;
-
- $r->read($buffer,$r->header_in('Content-length'),0);
- unless ($buffer=~/^(\-+\w+)\s+Content\-Disposition\:\s*form\-data/si) {
- my @pairs=split(/&/,$buffer);
- my $pair;
- foreach $pair (@pairs) {
- my ($name,$value) = split(/=/,$pair);
- $value =~ tr/+/ /;
- $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
- $name =~ tr/+/ /;
- $name =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
- &add_to_env("form.$name",$value);
- }
- } else {
- my $contentsep=$1;
- my @lines = split (/\n/,$buffer);
- my $name='';
- my $value='';
- my $fname='';
- my $fmime='';
- my $i;
- for ($i=0;$i<=$#lines;$i++) {
- if ($lines[$i]=~/^$contentsep/) {
- if ($name) {
- chomp($value);
- if ($fname) {
- $ENV{"form.$name.filename"}=$fname;
- $ENV{"form.$name.mimetype"}=$fmime;
- } else {
- $value=~s/\s+$//s;
- }
- &add_to_env("form.$name",$value);
+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 ($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='';
+ }
+ 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;
}
- $i++;
- }
- } else {
- $value.=$lines[$i]."\n";
- }
- }
+ }
+ 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);
+ }
+ }
+ }
+ }
}
- $ENV{'request.method'}=$ENV{'REQUEST_METHOD'};
- $r->method_number(M_GET);
- $r->method('GET');
- $r->headers_in->unset('Content-length');
+ return;
+}
+
+sub get_user_info {
+ my ($udom,$uname,$idx,$userdata) = @_;
+ $$userdata{$uname.':'.$udom}[$$idx{fullname}] =
+ &plainname($uname,$udom,'lastname');
+ $$userdata{$uname.':'.$udom}[$$idx{uname}] = $uname;
+ $$userdata{$uname.':'.$udom}[$$idx{udom}] = $udom;
+ return;
}
=pod
=item * get_unprocessed_cgi($query,$possible_names)
-Modify the %ENV hash to contain unprocessed CGI form parameters held in
+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.
+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.
+will result in $env{'form.uname'} and $env{'form.udom'} being set.
=cut
@@ -3013,8 +3720,7 @@ sub get_unprocessed_cgi {
if (!defined($possible_names) || (grep {$_ eq $name} @$possible_names)) {
$value =~ tr/+/ /;
$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
- &Apache::lonxml::debug("Seting :$name: to :$value:");
- unless (defined($ENV{'form.'.$name})) { &add_to_env('form.'.$name,$value) };
+ unless (defined($env{'form.'.$name})) { &add_to_env('form.'.$name,$value) };
}
}
}
@@ -3028,7 +3734,7 @@ returns cache-controlling header code
=cut
sub cacheheader {
- unless ($ENV{'request.method'} eq 'GET') { return ''; }
+ unless ($env{'request.method'} eq 'GET') { return ''; }
my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
my $output .='
@@ -3047,7 +3753,7 @@ specifies header code to not have cache
sub no_cache {
my ($r) = @_;
if ($ENV{'REQUEST_METHOD'} ne 'GET' &&
- $ENV{'request.method'} ne 'GET') { return ''; }
+ $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);
@@ -3056,7 +3762,11 @@ sub no_cache {
sub content_type {
my ($r,$type,$charset) = @_;
- if ($ENV{'browser.mathml'} && $type eq 'text/html') { $type='text/xml'; }
+ 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;
}
@@ -3072,7 +3782,7 @@ sub content_type {
=item * add_to_env($name,$value)
-adds $name to the %ENV hash with 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.
@@ -3080,18 +3790,18 @@ reference and $value is added to the arr
sub add_to_env {
my ($name,$value)=@_;
- if (defined($ENV{$name})) {
- if (ref($ENV{$name})) {
+ if (defined($env{$name})) {
+ if (ref($env{$name})) {
#already have multiple values
- push(@{ $ENV{$name} },$value);
+ 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);
+ my $first=$env{$name};
+ undef($env{$name});
+ push(@{ $env{$name} },$first,$value);
}
} else {
- $ENV{$name}=$value;
+ $env{$name}=$value;
}
}
@@ -3099,7 +3809,7 @@ sub add_to_env {
=item * get_env_multiple($name)
-gets $name from the %ENV hash, it seemlessly handles the cases where multiple
+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
@@ -3109,12 +3819,12 @@ returns an array of values
sub get_env_multiple {
my ($name) = @_;
my @values;
- if (defined($ENV{$name})) {
+ if (defined($env{$name})) {
# exists is it an array
- if (ref($ENV{$name})) {
- @values=@{ $ENV{$name} };
+ if (ref($env{$name})) {
+ @values=@{ $env{$name} };
} else {
- $values[0]=$ENV{$name};
+ $values[0]=$env{$name};
}
}
return(@values);
@@ -3132,25 +3842,25 @@ sub get_env_multiple {
=item * upfile_store($r)
Store uploaded file, $r should be the HTTP Request object,
-needs $ENV{'form.upfile'}
+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;
+ $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 $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'};
+ print $fh $env{'form.upfile'};
close($fh);
}
}
@@ -3162,8 +3872,8 @@ sub upfile_store {
=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
+needs $env{'form.datatoken'},
+sets $env{'form.upfile'} to the contents of the file
=cut
@@ -3172,13 +3882,13 @@ sub load_tmp_file {
my @studentdata=();
{
my $studentfile = $r->dir_config('lonDaemons').
- '/tmp/'.$ENV{'form.datatoken'}.'.tmp';
+ '/tmp/'.$env{'form.datatoken'}.'.tmp';
if ( open(my $fh,"<$studentfile") ) {
@studentdata=<$fh>;
close($fh);
}
}
- $ENV{'form.upfile'}=join('',@studentdata);
+ $env{'form.upfile'}=join('',@studentdata);
}
=pod
@@ -3187,15 +3897,15 @@ sub load_tmp_file {
Separate uploaded file into records
returns array of records,
-needs $ENV{'form.upfile'} and $ENV{'form.upfiletype'}
+needs $env{'form.upfile'} and $env{'form.upfiletype'}
=cut
sub upfile_record_sep {
- if ($ENV{'form.upfiletype'} eq 'xml') {
+ if ($env{'form.upfiletype'} eq 'xml') {
} else {
my @records;
- foreach my $line (split(/\n/,$ENV{'form.upfile'})) {
+ foreach my $line (split(/\n/,$env{'form.upfile'})) {
if ($line=~/^\s*$/) { next; }
push(@records,$line);
}
@@ -3207,30 +3917,35 @@ sub upfile_record_sep {
=item * record_sep($record)
-Separate a record into fields $record should be an item from the upfile_record_sep(), needs $ENV{'form.upfiletype'}
+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') {
+ if ($env{'form.upfiletype'} eq 'xml') {
+ } elsif ($env{'form.upfiletype'} eq 'space') {
my $i=0;
foreach (split(/\s+/,$record)) {
my $field=$_;
$field=~s/^(\"|\')//;
$field=~s/(\"|\')$//;
- $components{$i}=$field;
+ $components{&takeleft($i)}=$field;
$i++;
}
- } elsif ($ENV{'form.upfiletype'} eq 'tab') {
+ } elsif ($env{'form.upfiletype'} eq 'tab') {
my $i=0;
foreach (split(/\t/,$record)) {
my $field=$_;
$field=~s/^(\"|\')//;
$field=~s/(\"|\')$//;
- $components{$i}=$field;
+ $components{&takeleft($i)}=$field;
$i++;
}
} else {
@@ -3248,7 +3963,7 @@ sub record_sep {
$field=~s/^\s*$delimiter//;
$field=~s/$delimiter\s*$//;
}
- $components{$i}=$field;
+ $components{&takeleft($i)}=$field;
$i++;
}
}
@@ -3285,6 +4000,22 @@ sub upfile_select_html {
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;
+}
+
######################################################
######################################################
@@ -3302,18 +4033,15 @@ Apache Request ref, $records is an array
######################################################
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]);}
- #
+ my $samples = &get_samples($records,3);
+
$r->print(&mt('Samples').'');
- foreach (sort({$a <=> $b} keys(%sone))) {
+ foreach (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
$r->print(''.&mt('Column [_1]',($_+1)).' '); }
$r->print(' ');
- foreach my $hash (\%sone,\%stwo,\%sthree) {
+ foreach my $hash (@$samples) {
$r->print('');
- foreach (sort({$a <=> $b} keys(%sone))) {
+ foreach (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
$r->print('');
if (defined($$hash{$_})) { $r->print($$hash{$_}); }
$r->print(' ');
@@ -3342,8 +4070,8 @@ $d is an array of 2 element arrays (inte
######################################################
sub csv_print_select_table {
my ($r,$records,$d) = @_;
- my $i=0;my %sone;
- %sone=&record_sep($$records[0]);
+ my $i=0;
+ my $samples = &get_samples($records,1);
$r->print(&mt('Associate columns with student attributes.')."\n".
''.
''.&mt('Attribute').' '.
@@ -3355,7 +4083,7 @@ sub csv_print_select_table {
$r->print('');
$r->print(' ');
- foreach (sort({$a <=> $b} keys(%sone))) {
+ foreach (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
$r->print('Column '.($_+1).' ');
@@ -3386,28 +4114,27 @@ $d is an array of 2 element arrays (inte
######################################################
sub csv_samples_select_table {
my ($r,$records,$d) = @_;
- my %sone; my %stwo; my %sthree;
my $i=0;
#
+ my $samples = &get_samples($records,3);
$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) {
+
+ foreach my $key (sort(keys(%{ $samples->[0] }))) {
$r->print('');
- foreach (@$d) {
- my ($value,$display,$defaultcol)=@{ $_ };
+ foreach my $option (@$d) {
+ my ($value,$display,$defaultcol)=@{ $option };
$r->print(''.
$display.' ');
}
$r->print(' ');
- if (defined($sone{$_})) { $r->print($sone{$_}."\n"); }
- if (defined($stwo{$_})) { $r->print($stwo{$_}."\n"); }
- if (defined($sthree{$_})) { $r->print($sthree{$_}."\n"); }
+ foreach my $line (0..2) {
+ if (defined($samples->[$line]{$key})) {
+ $r->print($samples->[$line]{$key}." \n");
+ }
+ }
$r->print(' ');
$i++;
}
@@ -3496,7 +4223,7 @@ the routine &Apache::lonnet::transfer_pr
my $uniq=0;
sub get_cgi_id {
$uniq=($uniq+1)%100000;
- return (time.'_'.$uniq);
+ return (time.'_'.$$.'_'.$uniq);
}
############################################################
@@ -3915,34 +4642,35 @@ Returns: both routines return nothing
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 $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 = 'internal.'.$prefix.'.'.$setting;
- my $envname = 'course.'.$courseid.'.'.$basename;
- if (exists($ENV{'form.'.$setting})) {
+ 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};
+ (! exists($env{$envname}) ||
+ $env{$envname} ne $env{'form.'.$setting})) {
+ $SaveHash{$basename} = $env{'form.'.$setting};
+ $AppHash{$envname} = $env{'form.'.$setting};
} elsif ($type eq 'array') {
my $stored_form;
- if (ref($ENV{'form.'.$setting})) {
+ if (ref($env{'form.'.$setting})) {
$stored_form = join(',',
map {
&Apache::lonnet::escape($_);
- } sort(@{$ENV{'form.'.$setting}}));
+ } sort(@{$env{'form.'.$setting}}));
} else {
$stored_form =
- &Apache::lonnet::escape($ENV{'form.'.$setting});
+ &Apache::lonnet::escape($env{'form.'.$setting});
}
# Determine if the array contents are the same.
- if ($stored_form ne $ENV{$envname}) {
+ if ($stored_form ne $env{$envname}) {
$SaveHash{$basename} = $stored_form;
$AppHash{$envname} = $stored_form;
}
@@ -3950,8 +4678,7 @@ sub store_course_settings {
}
}
my $put_result = &Apache::lonnet::put('environment',\%SaveHash,
- $coursedom,
- $ENV{'course.'.$courseid.'.num'});
+ $udom,$uname);
if ($put_result !~ /^(ok|delayed)/) {
&Apache::lonnet::logthis('unable to save form parameters, '.
'got error:'.$put_result);
@@ -3962,20 +4689,20 @@ sub store_course_settings {
}
sub restore_course_settings {
- my $courseid = $ENV{'request.course.id'};
+ 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.
+ next if (exists($env{'form.'.$setting}));
+ my $envname = 'environment.internal.'.$courseid.'.'.$prefix.
'.'.$setting;
- if (exists($ENV{$envname})) {
+ if (exists($env{$envname})) {
if ($type eq 'scalar') {
- $ENV{'form.'.$setting} = $ENV{$envname};
+ $env{'form.'.$setting} = $env{$envname};
} elsif ($type eq 'array') {
- $ENV{'form.'.$setting} = [
+ $env{'form.'.$setting} = [
map {
&Apache::lonnet::unescape($_);
- } split(',',$ENV{$envname})
+ } split(',',$env{$envname})
];
}
}
';
- if ($ENV{'environment.texengine'} eq 'jsMath') {
- $endbodytag=''.
- "\n".$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 ..