@@ -2860,7 +2939,7 @@ ENDBODY
=back
-=head1 HTTP Helpers
+=head1 HTML Helpers
=over 4
@@ -2868,29 +2947,222 @@ 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='
';
- 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
+ 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 (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) = @_;
+ return &headtag($title,$head_extra).&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
+ force_register -> if is true will turn on the &bodytag()
+ $forcereg arg
+
+=back
+
+=cut
+
+sub start_page {
+ my ($title,$head_extra,$args) = @_;
+ my %head_args;
+ if (defined($args->{'redirect'})) {
+ $head_args{'redirect'} = $args->{'redirect'};
+ }
+ $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'}, undef,
+ $args->{'no_nav_bar'}, $args->{'bgcolor'});
+ if ($args->{'js_ready'}) {
+ $result = &js_ready($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
+=back
+
+=cut
+
+sub end_page {
+ my ($args) = @_;
+ $env{'internal.end_page'}++;
+ my $result = &endbodytag()."\n";
+ if ($args->{'js_ready'}) {
+ $result = &js_ready($result);
+ }
+ return $result;
+}
+
+sub js_ready {
+ my ($result) = @_;
+ $result = &HTML::Entities::encode($result,'<>&"');
+
+ $result =~ s/[\n\r]/ /g;
+ $result =~ s/'/\\'/g;
+
+ 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{'request.filename'});
+ }
+ if ( exists($env{'internal.end_page'})
+ && $env{'internal.end_page'} > 1) {
+ &Apache::lonnet::logthis('end_page called multiple times '.
+ $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'});
+ }
+}
+
###############################################
=pod
+=over 4
+
=item get_users_function
Used by &bodytag to determine the current users primary role.
@@ -2901,13 +3173,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';
}
@@ -2918,6 +3190,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
@@ -2936,11 +3262,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) {
@@ -2970,13 +3295,295 @@ sub get_sections {
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;
-
- $r->read($buffer,$r->header_in('Content-length'),0);
+ 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;
@@ -3001,8 +3608,8 @@ sub get_posted_cgi {
if ($name) {
chomp($value);
if ($fname) {
- $ENV{"form.$name.filename"}=$fname;
- $ENV{"form.$name.mimetype"}=$fmime;
+ $env{"form.$name.filename"}=$fname;
+ $env{"form.$name.mimetype"}=$fmime;
} else {
$value=~s/\s+$//s;
}
@@ -3034,7 +3641,7 @@ sub get_posted_cgi {
}
}
}
- $ENV{'request.method'}=$ENV{'REQUEST_METHOD'};
+ $env{'request.method'}=$ENV{'REQUEST_METHOD'};
$r->method_number(M_GET);
$r->method('GET');
$r->headers_in->unset('Content-length');
@@ -3044,14 +3651,14 @@ sub get_posted_cgi {
=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
@@ -3064,8 +3671,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) };
}
}
}
@@ -3079,7 +3685,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 .='
@@ -3098,7 +3704,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);
@@ -3107,7 +3713,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;
}
@@ -3123,7 +3733,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.
@@ -3131,18 +3741,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;
}
}
@@ -3150,7 +3760,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
@@ -3160,12 +3770,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);
@@ -3183,25 +3793,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);
}
}
@@ -3213,8 +3823,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
@@ -3223,13 +3833,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
@@ -3238,15 +3848,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);
}
@@ -3258,30 +3868,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 {
@@ -3299,7 +3914,7 @@ sub record_sep {
$field=~s/^\s*$delimiter//;
$field=~s/$delimiter\s*$//;
}
- $components{$i}=$field;
+ $components{&takeleft($i)}=$field;
$i++;
}
}
@@ -3336,6 +3951,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;
+}
+
######################################################
######################################################
@@ -3353,18 +3984,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').'
');
if (defined($$hash{$_})) { $r->print($$hash{$_}); }
$r->print('
');
@@ -3393,8 +4021,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').'
'.
@@ -3406,7 +4034,7 @@ sub csv_print_select_table {
$r->print('