--- loncom/interface/loncommon.pm 2005/11/08 03:12:35 1.284 +++ loncom/interface/loncommon.pm 2006/04/14 21:09:51 1.338 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # a pile of common routines # -# $Id: loncommon.pm,v 1.284 2005/11/08 03:12:35 albertel Exp $ +# $Id: loncommon.pm,v 1.338 2006/04/14 21:09:51 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -58,10 +58,11 @@ use strict; 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; @@ -331,7 +332,10 @@ sub storeresurl { sub studentbrowser_javascript { unless ( (($env{'request.course.id'}) && - (&Apache::lonnet::allowed('srm',$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'); @@ -362,7 +366,9 @@ ENDSTDBRW sub selectstudent_link { my ($form,$unameele,$udomele)=@_; if ($env{'request.course.id'}) { - unless (&Apache::lonnet::allowed('srm',$env{'request.course.id'})) { + if (!&Apache::lonnet::allowed('srm',$env{'request.course.id'}) + && !&Apache::lonnet::allowed('srm',$env{'request.course.id'}. + '/'.$env{'request.course.sec'})) { return ''; } return " var stdeditbrowser; - function opencrsbrowser(formname,uname,udom,desc,extra_element) { + function opencrsbrowser(formname,uname,udom,desc,extra_element,multflag) { var url = '/adm/pickcourse?'; var filter; if (filter != null) { @@ -403,6 +409,9 @@ sub coursebrowser_javascript { url += '&domainfilter='+extra_element; } } + if (multflag !=null && multflag != '') { + url += '&multiple='+multflag; + } var title = 'Course_Browser'; var options = 'scrollbars=1,resizable=1,menubar=0'; options += ',width=700,height=600'; @@ -414,9 +423,9 @@ ENDSTDBRW } sub selectcourse_link { - my ($form,$unameele,$udomele,$desc,$extra_element)=@_; + my ($form,$unameele,$udomele,$desc,$extra_element,$multflag)=@_; return "".&mt('Select Course').""; + '","'.$udomele.'","'.$desc.'","'.$extra_element.'","'.$multflag.'");'."'>".&mt('Select Course').""; } sub check_uncheck_jscript { @@ -713,8 +722,18 @@ sub help_open_menu { "$text"; } my $nothing=&Apache::lonhtmlcommon::javascript_nothing(); - my $html=&Apache::lonxml::xmlbegin(); my $helpicon=&lonhttpdurl("/adm/lonIcons/helpgateway.gif"); + my $start_page = + &Apache::loncommon::start_page('Help Menu', undef, + {'frameset' => 1, + 'js_ready' => 1, + 'add_entries' => { + 'border' => '0', + 'rows' => "105,*",},}); + my $end_page = + &Apache::loncommon::end_page({'frameset' => 1, + 'js_ready' => 1,}); + $template .= <<"ENDTEMPLATE"; }{}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. @@ -3076,6 +3432,153 @@ sub get_sections { } ############################################### + +=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 @@ -3090,64 +3593,108 @@ Incoming parameters: 3. access status: users must have - either active, previous, future, or all. 4. reference to array of permissible roles -5. reference to results object (hash of hashes). +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,$users) = @_; - if (grep/^st$/,@{$roles}) { - my $statusidx = &Apache::loncoursedata::CL_STATUS(); - my $startidx = &Apache::loncoursedata::CL_START(); - my $endidx = &Apache::loncoursedata::CL_END(); + 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}[$statusidx] eq 'Active') { + if ($$classlist{$student}[$idx{status}] eq 'Active') { push(@{$$users{st}{$student}},'active'); + $match = 1; } } if (defined($$types{'previous'})) { - if ($$classlist{$student}[$endidx] <= $now) { + if ($$classlist{$student}[$idx{end}] <= $now) { push(@{$$users{st}{$student}},'previous'); + $match = 1; } } if (defined($$types{'future'})) { - if (($$classlist{$student}[$startidx] > $now) && ($$classlist{$student}[$endidx] > $now) || ($$classlist{$student}[$endidx] == 0) || ($$classlist{$student}[$endidx] eq '')) { + 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(/^$role$/,@{$roles}))) { - my ($uname,$udom) = split(/:/,$user); + 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; + @{$$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 (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'; + @{$$users{'ow'}{$owner.':'.$cdom}} = 'any'; + if (defined($userdata) && + !exists($$userdata{$owner.':'.$cdom})) { + &get_user_info($cdom,$owner,\%idx,$userdata); + } } } } @@ -3155,78 +3702,13 @@ sub get_course_users { return; } - - -############################################### - -sub get_posted_cgi { - my $r=shift; - - my $buffer; - if ($r->header_in('Content-length')) { - $r->read($buffer,$r->header_in('Content-length'),0); - } - unless ($buffer=~/^(\-+\w+)\s+Content\-Disposition\:\s*form\-data/si) { - my @pairs=split(/&/,$buffer); - my $pair; - foreach $pair (@pairs) { - my ($name,$value) = split(/=/,$pair); - $value =~ tr/+/ /; - $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; - $name =~ tr/+/ /; - $name =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; - &add_to_env("form.$name",$value); - } - } else { - my $contentsep=$1; - my @lines = split (/\n/,$buffer); - my $name=''; - my $value=''; - my $fname=''; - my $fmime=''; - my $i; - for ($i=0;$i<=$#lines;$i++) { - if ($lines[$i]=~/^$contentsep/) { - if ($name) { - chomp($value); - if ($fname) { - $env{"form.$name.filename"}=$fname; - $env{"form.$name.mimetype"}=$fmime; - } else { - $value=~s/\s+$//s; - } - &add_to_env("form.$name",$value); - } - if ($i<$#lines) { - $i++; - $lines[$i]=~ - /Content\-Disposition\:\s*form\-data\;\s*name\=\"([^\"]+)\"/i; - $name=$1; - $value=''; - if ($lines[$i]=~/filename\=\"([^\"]+)\"/i) { - $fname=$1; - if - ($lines[$i+1]=~/Content\-Type\:\s*([\w\-\/]+)/i) { - $fmime=$1; - $i++; - } else { - $fmime=''; - } - } else { - $fname=''; - $fmime=''; - } - $i++; - } - } else { - $value.=$lines[$i]."\n"; - } - } - } - $env{'request.method'}=$ENV{'REQUEST_METHOD'}; - $r->method_number(M_GET); - $r->method('GET'); - $r->headers_in->unset('Content-length'); +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 @@ -3295,6 +3777,10 @@ sub 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; @@ -3529,6 +4015,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; +} + ###################################################### ###################################################### @@ -3546,18 +4048,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(''); } $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(''); @@ -3586,8 +4085,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('Column [_1]',($_+1)).'
'); if (defined($$hash{$_})) { $r->print($$hash{$_}); } $r->print('

'. ''. @@ -3599,7 +4098,7 @@ sub csv_print_select_table { $r->print('

'.&mt('Attribute').'

'); - %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(''); $i++; } @@ -4160,13 +4658,14 @@ 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 $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; + my $basename = join('.','internal',$courseid,$prefix,$setting); + my $envname = 'environment.'.$basename; if (exists($env{'form.'.$setting})) { # Save this value away if ($type eq 'scalar' && @@ -4194,8 +4693,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); @@ -4210,7 +4708,7 @@ sub restore_course_settings { my ($prefix,$Settings) = @_; while (my ($setting,$type) = each(%$Settings)) { next if (exists($env{'form.'.$setting})); - my $envname = 'course.'.$courseid.'.internal.'.$prefix. + my $envname = 'environment.internal.'.$courseid.'.'.$prefix. '.'.$setting; if (exists($env{$envname})) { if ($type eq 'scalar') {

'. &mt('Field').'	'.&mt('Samples').'
	'); - 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('