--- loncom/interface/loncommon.pm 2007/07/07 00:53:24 1.547 +++ loncom/interface/loncommon.pm 2009/05/21 15:43:52 1.692.4.3 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # a pile of common routines # -# $Id: loncommon.pm,v 1.547 2007/07/07 00:53:24 albertel Exp $ +# $Id: loncommon.pm,v 1.692.4.3 2009/05/21 15:43:52 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -61,12 +61,15 @@ use POSIX qw(strftime mktime); use Apache::lonmenu(); use Apache::lonenc(); use Apache::lonlocal; +use Apache::lonnet(); use HTML::Entities; use Apache::lonhtmlcommon(); use Apache::loncoursedata(); use Apache::lontexconvert(); use Apache::lonclonecourse(); use LONCAPA qw(:DEFAULT :match); +use DateTime::TimeZone; +use DateTime::Locale::Catalog; # ---------------------------------------------- Designs use vars qw(%defaultdesign); @@ -78,6 +81,76 @@ my $readit; ## Global Variables ## + +# ----------------------------------------------- SSI with retries: +# + +=pod + +=head1 Server Side include with retries: + +=over 4 + +=item * &ssi_with_retries(resource,retries form) + +Performs an ssi with some number of retries. Retries continue either +until the result is ok or until the retry count supplied by the +caller is exhausted. + +Inputs: + +=over 4 + +resource - Identifies the resource to insert. + +retries - Count of the number of retries allowed. + +form - Hash that identifies the rendering options. + +=back + +Returns: + +=over 4 + +content - The content of the response. If retries were exhausted this is empty. + +response - The response from the last attempt (which may or may not have been successful. + +=back + +=back + +=cut + +sub ssi_with_retries { + my ($resource, $retries, %form) = @_; + + + my $ok = 0; # True if we got a good response. + my $content; + my $response; + + # Try to get the ssi done. within the retries count: + + do { + ($content, $response) = &Apache::lonnet::ssi($resource, %form); + $ok = $response->is_success; + if (!$ok) { + &Apache::lonnet::logthis("Failed ssi_with_retries on $resource: ".$response->is_success.', '.$response->code.', '.$response->message); + } + $retries--; + } while (!$ok && ($retries > 0)); + + if (!$ok) { + $content = ''; # On error return an empty content. + } + return ($content, $response); + +} + + + # ----------------------------------------------- Filetypes/Languages/Copyright my %language; my %supported_language; @@ -214,14 +287,14 @@ BEGIN { =over 4 -=item * browser_and_searcher_javascript () +=item * &browser_and_searcher_javascript() XXReturns a string containing javascript with two functions, C and C. Returned string does not contain EscriptE tags. -=item * openbrowser(formname,elementname,only,omit) [javascript] +=item * &openbrowser(formname,elementname,only,omit) [javascript] inputs: formname, elementname, only, omit @@ -234,7 +307,7 @@ with the given extension. Can be a comm Specifying 'omit' will restrict the browser to NOT displaying files with the given extension. Can be a comma separated list. -=item * opensearcher(formname, elementname) [javascript] +=item * &opensearcher(formname,elementname) [javascript] Inputs: formname, elementname @@ -257,6 +330,7 @@ sub browser_and_searcher_javascript { } url += 'catalogmode=interactive&'; url += 'mode=$mode&'; + url += 'inhibitmenu=yes&'; url += 'form=' + formname + '&'; if (only != null) { url += 'only=' + only + '&'; @@ -318,7 +392,7 @@ sub storeresurl { unless ($resurl=~/^\/res/) { return 0; } $resurl=~s/\/$//; &Apache::lonnet::put('environment',{'lastresurl' => $resurl}); - &Apache::lonnet::appenv('environment.lastresurl' => $resurl); + &Apache::lonnet::appenv({'environment.lastresurl' => $resurl}); return 1; } @@ -332,12 +406,14 @@ sub studentbrowser_javascript { || ($env{'request.role'}=~/^(au|dc|su)/) ) { return ''; } return (<<'ENDSTDBRW'); - +ENDAUTHORBRW +} + sub coursebrowser_javascript { my ($domainfilter,$sec_element,$formname)=@_; my $crs_or_grp_alert = &mt('Please select the type of LON-CAPA entity - Course or Group - for which you wish to add/modify a user role'); my $output = ' - block and html for two element int multiple mode @@ -1305,7 +1665,7 @@ sub multiple_select_form { $size = scalar(keys(%$hash)); } } - $output.="\n'; my @order; if (ref($order) eq 'ARRAY') { @order = @{$order}; @@ -1329,7 +1689,7 @@ sub multiple_select_form { =pod -=item * select_form($defdom,$name,%hash) +=item * &select_form($defdom,$name,%hash) Returns a string containing a '; + ''; } sub gradeleveldescription { @@ -1416,7 +1776,7 @@ sub select_level_form { =pod -=item * select_dom_form($defdom,$name,$includeempty) +=item * &select_dom_form($defdom,$name,$includeempty,$showdomdesc,$autosubmit) Returns a string containing a \n"; + my $selectdomain = ""; return $selectdomain; @@ -1446,24 +1822,68 @@ sub select_dom_form { =pod -=item * home_server_option_list($domain) +=item * &home_server_form_item($domain,$name,$defaultflag) + +input: 4 arguments (two required, two optional) - + $domain - domain of new user + $name - name of form element + $default - Value of 'default' causes a default item to be first + option, and selected by default. + $hide - Value of 'hide' causes hiding of the name of the server, + if 1 server found, or default, if 0 found. +output: returns 2 items: +(a) form element which contains either: + (i) + form item if there are multiple library servers in $domain, or + (ii) an form item + if there is only one library server in $domain. -returns a string which contains an '."\n"; + } + foreach my $hostid (sort(keys(%servers))) { + $result.= '\n"; + } + $result .= ''."\n"; + } elsif ($numlib == 1) { + my $hostid; + foreach my $item (keys(%servers)) { + $hostid = $item; + } + $result .= ''; + if (!$hide) { + $result .= $hostid.' '.$servers{$hostid}; + } + $result .= "\n"; + } elsif ($default) { + $result .= ''; + if (!$hide) { + $result .= &mt('default'); + } + $result .= "\n"; } - return $result; + return ($result,$numlib); } =pod @@ -1562,14 +1982,12 @@ sub decode_user_agent { =over 4 -=item * authform_xxxxxx +=item * &authform_xxxxxx() The authform_xxxxxx subroutines provide javascript and html forms which handle some of the conveniences required for authentication forms. This is not an optimal method, but it works. -See loncreateuser.pm for invocation and use examples. - =over 4 =item * authform_header @@ -1586,7 +2004,7 @@ See loncreateuser.pm for invocation and =back -=back +See loncreateuser.pm for invocation and use examples. =cut @@ -1616,19 +2034,16 @@ END } my $radioval = "'nochange'"; - if (exists($in{'curr_authtype'}) && - defined($in{'curr_authtype'}) && - $in{'curr_authtype'} ne '') { - $radioval = "'$in{'curr_authtype'}arg'"; + if (defined($in{'curr_authtype'})) { + if ($in{'curr_authtype'} ne '') { + $radioval = "'".$in{'curr_authtype'}."arg'"; + } } my $argfield = 'null'; - if ( grep/^mode$/,(keys %in) ) { + if (defined($in{'mode'})) { if ($in{'mode'} eq 'modifycourse') { - if ( grep/^curr_authtype$/,(keys %in) ) { - $radioval = "'$in{'curr_authtype'}'"; - } - if ( grep/^curr_autharg$/,(keys %in) ) { - unless ($in{'curr_autharg'} eq '') { + if (defined($in{'curr_autharg'})) { + if ($in{'curr_autharg'} ne '') { $argfield = "'$in{'curr_autharg'}'"; } } @@ -1711,79 +2126,181 @@ sub authform_nochange{ kerb_def_dom => 'MSU.EDU', @_, ); - my $result = ''; + } return $result; } -sub authform_kerberos{ +sub authform_kerberos { my %in = ( formname => 'document.cu', kerb_def_dom => 'MSU.EDU', kerb_def_auth => 'krb4', @_, ); - my ($check4,$check5,$krbarg); + my ($check4,$check5,$krbcheck,$krbarg,$krbver,$result,$authtype, + $autharg,$jscall); + my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'}); if ($in{'kerb_def_auth'} eq 'krb5') { - $check5 = " checked=\"on\""; + $check5 = ' checked="checked"'; } else { - $check4 = " checked=\"on\""; + $check4 = ' checked="checked"'; } $krbarg = $in{'kerb_def_dom'}; - - my $krbcheck = ""; - if ( grep/^curr_authtype$/,(keys %in) ) { - if ($in{'curr_authtype'} =~ m/^krb/) { - $krbcheck = " checked=\"on\""; - if ( grep/^curr_autharg$/,(keys %in) ) { + if (defined($in{'curr_authtype'})) { + if ($in{'curr_authtype'} eq 'krb') { + $krbcheck = ' checked="checked"'; + if (defined($in{'mode'})) { + if ($in{'mode'} eq 'modifyuser') { + $krbcheck = ''; + } + } + if (defined($in{'curr_kerb_ver'})) { + if ($in{'curr_krb_ver'} eq '5') { + $check5 = ' checked="checked"'; + $check4 = ''; + } else { + $check4 = ' checked="checked"'; + $check5 = ''; + } + } + if (defined($in{'curr_autharg'})) { $krbarg = $in{'curr_autharg'}; } + if (!$can_assign{'krb4'} && !$can_assign{'krb5'}) { + if (defined($in{'curr_autharg'})) { + $result = + &mt('Currently Kerberos authenticated with domain [_1] Version [_2].', + $in{'curr_autharg'},$krbver); + } else { + $result = + &mt('Currently Kerberos authenticated, Version [_1].',$krbver); + } + return $result; + } + } + } else { + if ($authnum == 1) { + $authtype = ''; } } - - my $jscall = "javascript:changed_radio('krb',$in{'formname'});"; - my $result .= &mt + if (!$can_assign{'krb4'} && !$can_assign{'krb5'}) { + return; + } elsif ($authtype eq '') { + if (defined($in{'mode'})) { + if ($in{'mode'} eq 'modifycourse') { + if ($authnum == 1) { + $authtype = ''; + } + } + } + } + $jscall = "javascript:changed_radio('krb',$in{'formname'});"; + if ($authtype eq '') { + $authtype = ''; + } + if (($can_assign{'krb4'} && $can_assign{'krb5'}) || + ($can_assign{'krb4'} && !$can_assign{'krb5'} && + $in{'curr_authtype'} eq 'krb5') || + (!$can_assign{'krb4'} && $can_assign{'krb5'} && + $in{'curr_authtype'} eq 'krb4')) { + $result .= &mt ('[_1] Kerberos authenticated with domain [_2] '. '[_3] Version 4 [_4] Version 5 [_5]', - ''); return $result; } -############################################################### -## Get Authentication Defaults for Domain ## -############################################################### - -=pod - -=head1 Domains and Authentication - -Returns default authentication type and an associated argument as -listed in file 'domain.tab'. - -=over 4 - -=item * get_auth_defaults - -get_auth_defaults($target_domain) returns the default authentication -type and an associated argument (initial password or a kerberos domain). -These values are stored in lonTabs/domain.tab - -($def_auth, $def_arg) = &get_auth_defaults($target_domain); - -If target_domain is not found in domain.tab, returns nothing (''). - -=cut - -#------------------------------------------- -sub get_auth_defaults { - my $domain=shift; - return (&Apache::lonnet::domain($domain,'auth_def'), - &Apache::lonnet::domain($domain,'auth_arg_def')); - +sub get_assignable_auth { + my ($dom) = @_; + if ($dom eq '') { + $dom = $env{'request.role.domain'}; + } + my %can_assign = ( + krb4 => 1, + krb5 => 1, + int => 1, + loc => 1, + ); + my %domconfig = &Apache::lonnet::get_dom('configuration',['usercreation'],$dom); + if (ref($domconfig{'usercreation'}) eq 'HASH') { + if (ref($domconfig{'usercreation'}{'authtypes'}) eq 'HASH') { + my $authhash = $domconfig{'usercreation'}{'authtypes'}; + my $context; + if ($env{'request.role'} =~ /^au/) { + $context = 'author'; + } elsif ($env{'request.role'} =~ /^dc/) { + $context = 'domain'; + } elsif ($env{'request.course.id'}) { + $context = 'course'; + } + if ($context) { + if (ref($authhash->{$context}) eq 'HASH') { + %can_assign = %{$authhash->{$context}}; + } + } + } + } + my $authnum = 0; + foreach my $key (keys(%can_assign)) { + if ($can_assign{$key}) { + $authnum ++; + } + } + if ($can_assign{'krb4'} && $can_assign{'krb5'}) { + $authnum --; + } + return ($authnum,%can_assign); } -############################################################### -## End Get Authentication Defaults for Domain ## -############################################################### ############################################################### ## Get Kerberos Defaults for Domain ## @@ -1878,22 +2467,31 @@ sub get_auth_defaults { =pod -=item * get_kerberos_defaults +=item * &get_kerberos_defaults() get_kerberos_defaults($target_domain) returns the default kerberos -version and domain. If not found in domain.tabs, it defaults to -version 4 and the domain of the server. +version and domain. If not found, it defaults to version 4 and the +domain of the server. + +=over 4 ($def_version, $def_krb_domain) = &get_kerberos_defaults($target_domain); +=back + +=back + =cut #------------------------------------------- sub get_kerberos_defaults { my $domain=shift; - my ($krbdef,$krbdefdom) = - &Apache::loncommon::get_auth_defaults($domain); - unless ($krbdef =~/^krb/ && $krbdefdom) { + my ($krbdef,$krbdefdom); + my %domdefaults = &Apache::lonnet::get_domain_defaults($domain); + if (($domdefaults{'auth_def'} =~/^krb(4|5)$/) && ($domdefaults{'auth_arg_def'} ne '')) { + $krbdef = $domdefaults{'auth_def'}; + $krbdefdom = $domdefaults{'auth_arg_def'}; + } else { $ENV{'SERVER_NAME'}=~/(\w+\.\w+)$/; my $krbdefdom=$1; $krbdefdom=~tr/a-z/A-Z/; @@ -1902,11 +2500,6 @@ sub get_kerberos_defaults { return ($krbdef,$krbdefdom); } -=pod - -=back - -=cut ############################################################### ## Thesaurus Functions ## @@ -1918,7 +2511,7 @@ sub get_kerberos_defaults { =over 4 -=item * initialize_keywords +=item * &initialize_keywords() Initializes the package variable %Keywords if it is empty. Uses the package variable $thesaurus_db_file. @@ -1955,7 +2548,7 @@ sub initialize_keywords { # Remove special values from %Keywords. foreach my $value ('total.count','average.count') { delete($Keywords{$value}) if (exists($Keywords{$value})); - } + } return 1; } @@ -1963,7 +2556,7 @@ sub initialize_keywords { =pod -=item * keyword($word) +=item * &keyword($word) Returns true if $word is a keyword. A keyword is a word that appears more than the average number of times in the thesaurus database. Calls @@ -1984,7 +2577,7 @@ sub keyword { =pod -=item * get_related_words +=item * &get_related_words() Look up a word in the thesaurus. Takes a scalar argument and returns an array of words. If the keyword is not in the thesaurus, an empty array @@ -2042,7 +2635,7 @@ sub get_related_words { =over 4 -=item * plainname($uname,$udom,$first) +=item * &plainname($uname,$udom,$first) Takes a users logon name and returns it as a string in "first middle last generation" form @@ -2071,7 +2664,7 @@ sub plainname { # -------------------------------------------------------------------- Nickname =pod -=item * nickname($uname,$udom) +=item * &nickname($uname,$udom) Gets a users name and returns it as a string as @@ -2121,18 +2714,21 @@ sub getnames { } # -------------------------------------------------------------------- getemails + =pod -=item * getemails($uname,$udom) +=item * &getemails($uname,$udom) Gets a user's email information and returns it as a hash with keys: notification, critnotification, permanentemail For notification and critnotification, values are comma-separated lists -of e-mail address(es); for permanentemail, value is a single e-mail address. +of e-mail addresses; for permanentemail, value is a single e-mail address. + =cut + sub getemails { my ($uname,$udom)=@_; if ($udom eq 'public' && $uname eq 'public') { @@ -2154,11 +2750,57 @@ sub getemails { } } +sub flush_email_cache { + my ($uname,$udom)=@_; + if (!$udom) { $udom =$env{'user.domain'}; } + if (!$uname) { $uname=$env{'user.name'}; } + return if ($udom eq 'public' && $uname eq 'public'); + my $id=$uname.':'.$udom; + &Apache::lonnet::devalidate_cache_new('emailscache',$id); +} + +# -------------------------------------------------------------------- getlangs + +=pod + +=item * &getlangs($uname,$udom) + +Gets a user's language preference and returns it as a hash with key: +language. + +=cut + + +sub getlangs { + my ($uname,$udom) = @_; + if (!$udom) { $udom =$env{'user.domain'}; } + if (!$uname) { $uname=$env{'user.name'}; } + my $id=$uname.':'.$udom; + my ($langs,$cached)=&Apache::lonnet::is_cached_new('userlangs',$id); + if ($cached) { + return %{$langs}; + } else { + my %loadlangs=&Apache::lonnet::get('environment',['languages'], + $udom,$uname); + &Apache::lonnet::do_cache_new('userlangs',$id,\%loadlangs); + return %loadlangs; + } +} + +sub flush_langs_cache { + my ($uname,$udom)=@_; + if (!$udom) { $udom =$env{'user.domain'}; } + if (!$uname) { $uname=$env{'user.name'}; } + return if ($udom eq 'public' && $uname eq 'public'); + my $id=$uname.':'.$udom; + &Apache::lonnet::devalidate_cache_new('userlangs',$id); +} + # ------------------------------------------------------------------ Screenname =pod -=item * screenname($uname,$udom) +=item * &screenname($uname,$udom) Gets a users screenname and returns it as a string @@ -2172,6 +2814,25 @@ sub screenname { return $names{'screenname'}; } +# ------------------------------------------------------------- Confirm Wrapper +=pod + +=item confirmwrapper + +Wrap messages about completion of operation in box + +=cut + +sub confirmwrapper { + my ($message)=@_; + if ($message) { + return "\n".'
'."\n" + .$message."\n" + .'
'."\n"; + } else { + return $message; + } +} # ------------------------------------------------------------- Message Wrapper @@ -2198,7 +2859,7 @@ sub aboutmewrapper { return; } return ''.$link.''; + ($target?' target="$target"':'').' title="'.&mt("View this user's personal information page").'">'.$link.''; } # ------------------------------------------------------------ Syllabus Wrapper @@ -2227,11 +2888,33 @@ sub track_student_link { $target = ''; } if ($start) { $link.='&start='.$start; } - + $title = &mt($title); + $linktext = &mt($linktext); return qq{$linktext}. &help_open_topic('View_recent_activity'); } +sub slot_reservations_link { + my ($linktext,$sname,$sdom,$target) = @_; + my $link ="/adm/slotrequest?command=showresv&origin=aboutme"; + my $title = 'View slot reservation history'; + if (defined($sname) && $sname !~ /^\s*$/ && + defined($sdom) && $sdom !~ /^\s*$/) { + $link .= "&uname=$sname&udom=$sdom"; + $title .= ' of this student'; + } + if (defined($target) && $target !~ /^\s*$/) { + $target = qq{target="$target"}; + } else { + $target = ''; + } + $title = &mt($title); + $linktext = &mt($linktext); + return qq{$linktext}; +# FIXME uncomment when help item created: &help_open_topic('Slot_Reservation_History'); + +} + # ===================================================== Display a student photo @@ -2253,7 +2936,7 @@ sub student_image_tag { =over 4 -=item * languageids() +=item * &languageids() returns list of all language ids @@ -2265,7 +2948,7 @@ sub languageids { =pod -=item * languagedescription() +=item * &languagedescription() returns description of a specified language id @@ -2290,7 +2973,7 @@ sub supportedlanguagecode { =pod -=item * copyrightids() +=item * ©rightids() returns list of all copyrights @@ -2302,7 +2985,7 @@ sub copyrightids { =pod -=item * copyrightdescription() +=item * ©rightdescription() returns description of a specified copyright id @@ -2314,7 +2997,7 @@ sub copyrightdescription { =pod -=item * source_copyrightids() +=item * &source_copyrightids() returns list of all source copyrights @@ -2326,7 +3009,7 @@ sub source_copyrightids { =pod -=item * source_copyrightdescription() +=item * &source_copyrightdescription() returns description of a specified source copyright id @@ -2338,7 +3021,7 @@ sub source_copyrightdescription { =pod -=item * filecategories() +=item * &filecategories() returns list of all file categories @@ -2350,7 +3033,7 @@ sub filecategories { =pod -=item * filecategorytypes() +=item * &filecategorytypes() returns list of file types belonging to a given file category @@ -2364,7 +3047,7 @@ sub filecategorytypes { =pod -=item * fileembstyle() +=item * &fileembstyle() returns embedding style for a specified file type @@ -2388,7 +3071,7 @@ sub filecategoryselect { =pod -=item * filedescription() +=item * &filedescription() returns description for a specified file type @@ -2402,7 +3085,7 @@ sub filedescription { =pod -=item * filedescriptionex() +=item * &filedescriptionex() returns description for a specified file type with extra formatting @@ -2434,7 +3117,7 @@ sub fileextensions { sub display_languages { my %languages=(); - foreach my $lang (&preferred_languages()) { + foreach my $lang (&Apache::lonlocal::preferred_languages()) { $languages{$lang}=1; } &get_unprocessed_cgi($ENV{'QUERY_STRING'},['displaylanguage']); @@ -2446,46 +3129,49 @@ sub display_languages { return %languages; } -sub preferred_languages { - my @languages=(); - if ($env{'course.'.$env{'request.course.id'}.'.languages'}) { - @languages=(@languages,split(/\s*(\,|\;|\:)\s*/, - $env{'course.'.$env{'request.course.id'}.'.languages'})); - } - if ($env{'environment.languages'}) { - @languages=(@languages, - split(/\s*(\,|\;|\:)\s*/,$env{'environment.languages'})); - } - my $browser=(split(/\;/,$ENV{'HTTP_ACCEPT_LANGUAGE'}))[0]; - if ($browser) { - @languages=(@languages,split(/\s*(\,|\;|\:)\s*/,$browser)); - } - if (&Apache::lonnet::domain($env{'user.domain'},'lang_def')) { - @languages=(@languages, - &Apache::lonnet::domain($env{'user.domain'}, - 'lang_def')); - } - if (&Apache::lonnet::domain($env{'request.role.domain'},'lang_def')) { - @languages=(@languages, - &Apache::lonnet::domain($env{'request.role.domain'}, - 'lang_def')); - } - if (&Apache::lonnet::domain($Apache::lonnet::perlvar{'lonDefDomain'}, - 'lang_def')) { - @languages=(@languages, - &Apache::lonnet::domain($Apache::lonnet::perlvar{'lonDefDomain'}, - 'lang_def')); - } -# turn "en-ca" into "en-ca,en" - my @genlanguages; - foreach my $lang (@languages) { - unless ($lang=~/\w/) { next; } - push (@genlanguages,$lang); - if ($lang=~/(\-|\_)/) { - push(@genlanguages,(split(/(\-|\_)/,$lang))[0]); +sub languages { + my ($possible_langs) = @_; + my @preferred_langs = &Apache::lonlocal::preferred_languages(); + if (!ref($possible_langs)) { + if( wantarray ) { + return @preferred_langs; + } else { + return $preferred_langs[0]; + } + } + my %possibilities = map { $_ => 1 } (@$possible_langs); + my @preferred_possibilities; + foreach my $preferred_lang (@preferred_langs) { + if (exists($possibilities{$preferred_lang})) { + push(@preferred_possibilities, $preferred_lang); } } - return @genlanguages; + if( wantarray ) { + return @preferred_possibilities; + } + return $preferred_possibilities[0]; +} + +sub user_lang { + my ($touname,$toudom,$fromcid) = @_; + my @userlangs; + if (($fromcid ne '') && ($env{'course.'.$fromcid.'.languages'} ne '')) { + @userlangs=(@userlangs,split(/\s*(\,|\;|\:)\s*/, + $env{'course.'.$fromcid.'.languages'})); + } else { + my %langhash = &getlangs($touname,$toudom); + if ($langhash{'languages'} ne '') { + @userlangs = split(/\s*(\,|\;|\:)\s*/,$langhash{'languages'}); + } else { + my %domdefs = &Apache::lonnet::get_domain_defaults($toudom); + if ($domdefs{'lang_def'} ne '') { + @userlangs = ($domdefs{'lang_def'}); + } + } + } + my @languages=&Apache::lonlocal::get_genlanguages(@userlangs); + my $user_lh = Apache::localize->get_handle(@languages); + return $user_lh; } ############################################################### @@ -2498,7 +3184,7 @@ sub preferred_languages { =over 4 -=item * get_previous_attempt($symb, $username, $domain, $course, +=item * &get_previous_attempt($symb, $username, $domain, $course, $getattempt, $regexp, $gradesub) Return string with previous attempt on problem. Arguments: @@ -2542,14 +3228,14 @@ sub get_previous_attempt { $lasthash{$key}=$returnhash{$version.':'.$key}; } } - $prevattempts='
'; - $prevattempts.=''; + $prevattempts=&start_data_table().&start_data_table_header_row(); + $prevattempts.=''; foreach my $key (sort(keys(%lasthash))) { my ($ign,@parts) = split(/\./,$key); if ($#parts > 0) { my $data=$parts[-1]; pop(@parts); - $prevattempts.=''; + $prevattempts.=''; } else { if ($#parts == 0) { $prevattempts.=''; @@ -2558,41 +3244,53 @@ sub get_previous_attempt { } } } + $prevattempts.=&end_data_table_header_row(); if ($getattempt eq '') { for ($version=1;$version<=$returnhash{'version'};$version++) { - $prevattempts.=''; + $prevattempts.=&start_data_table_row(). + ''; foreach my $key (sort(keys(%lasthash))) { - my $value; - if ($key =~ /timestamp/) { - $value=scalar(localtime($returnhash{$version.':'.$key})); - } else { - $value=$returnhash{$version.':'.$key}; - } - $prevattempts.=''; + my $value = &format_previous_attempt_value($key, + $returnhash{$version.':'.$key}); + $prevattempts.=''; } + $prevattempts.=&end_data_table_row(); } } - $prevattempts.=''; + $prevattempts.=&start_data_table_row().''; foreach my $key (sort(keys(%lasthash))) { - my $value; - if ($key =~ /timestamp/) { - $value=scalar(localtime($lasthash{$key})); - } else { - $value=$lasthash{$key}; - } - $value=&unescape($value); + my $value = &format_previous_attempt_value($key,$lasthash{$key}); if ($key =~/$regexp$/ && (defined &$gradesub)) {$value = &$gradesub($value)} $prevattempts.=''; } - $prevattempts.='
History'.&mt('History').'Part '.join('.',@parts).'
'.$data.' 		'.&mt('Part ').join('.',@parts).'
'.$data.' 		'.$parts[0].'
Transaction '.$version.''.&mt('Transaction [_1]',$version).''.&unescape($value).' '.$value.' 
Current'.&mt('Current').''.$value.' 
'; + $prevattempts.= &end_data_table_row().&end_data_table(); } else { - $prevattempts='Nothing submitted - no attempts.'; + $prevattempts= + &start_data_table().&start_data_table_row(). + ''.&mt('Nothing submitted - no attempts.').''. + &end_data_table_row().&end_data_table(); } } else { - $prevattempts='No data.'; + $prevattempts= + &start_data_table().&start_data_table_row(). + ''.&mt('No data.').''. + &end_data_table_row().&end_data_table(); } } +sub format_previous_attempt_value { + my ($key,$value) = @_; + if ($key =~ /timestamp/) { + $value = &Apache::lonlocal::locallocaltime($value); + } elsif (ref($value) eq 'ARRAY') { + $value = '('.join(', ', @{ $value }).')'; + } else { + $value = &unescape($value); + } + return $value; +} + + sub relative_to_absolute { my ($url,$output)=@_; my $parser=HTML::TokeParser->new(\$output); @@ -2614,7 +3312,7 @@ sub relative_to_absolute { } $thisdir=~s-/[^/]*$--; foreach my $link (@rlinks) { - unless (($link=~/^http:\/\//i) || + unless (($link=~/^https?\:\/\//i) || ($link=~/^\//) || ($link=~/^javascript:/i) || ($link=~/^mailto:/i) || @@ -2630,7 +3328,7 @@ sub relative_to_absolute { =pod -=item * get_student_view +=item * &get_student_view() show a snapshot of what student was looking at @@ -2649,7 +3347,7 @@ sub get_student_view { } if (defined($target)) { $form{'grade_target'} = $target; } $feedurl=&Apache::lonnet::clutter($feedurl); - my $userview=&Apache::lonnet::ssi_body($feedurl,%form); + my ($userview,$response)=&Apache::lonnet::ssi_body($feedurl,%form); $userview=~s/\]*\>//gi; $userview=~s/\<\/body\>//gi; $userview=~s/\//gi; @@ -2658,12 +3356,44 @@ sub get_student_view { $userview=~s/\<\/head\>//gi; $userview=~s/action\s*\=/would_be_action\=/gi; $userview=&relative_to_absolute($feedurl,$userview); - return $userview; + if (wantarray) { + return ($userview,$response); + } else { + return $userview; + } +} + +sub get_student_view_with_retries { + my ($symb,$retries,$username,$domain,$courseid,$target,$moreenv) = @_; + + my $ok = 0; # True if we got a good response. + my $content; + my $response; + + # Try to get the student_view done. within the retries count: + + do { + ($content, $response) = &get_student_view($symb,$username,$domain,$courseid,$target,$moreenv); + $ok = $response->is_success; + if (!$ok) { + &Apache::lonnet::logthis("Failed get_student_view_with_retries on $symb: ".$response->is_success.', '.$response->code.', '.$response->message); + } + $retries--; + } while (!$ok && ($retries > 0)); + + if (!$ok) { + $content = ''; # On error return an empty content. + } + if (wantarray) { + return ($content, $response); + } else { + return $content; + } } =pod -=item * get_student_answers() +=item * &get_student_answers() show a snapshot of how student was answering problem @@ -2751,9 +3481,9 @@ sub pprmlink { if (!$symb) { $symb=&Apache::lonnet::symbread(); } $symb=&escape($symb); if ($target) { $target="target=\"$target\""; } - return ''.$text.''; + return ''.$text.''; } ############################################## @@ -2767,16 +3497,21 @@ sub pprmlink { sub timehash { - my @ltime=localtime(shift); - return ( 'seconds' => $ltime[0], - 'minutes' => $ltime[1], - 'hours' => $ltime[2], - 'day' => $ltime[3], - 'month' => $ltime[4]+1, - 'year' => $ltime[5]+1900, - 'weekday' => $ltime[6], - 'dayyear' => $ltime[7]+1, - 'dlsav' => $ltime[8] ); + my ($thistime) = @_; + my $timezone = &Apache::lonlocal::gettimezone(); + my $dt = DateTime->from_epoch(epoch => $thistime) + ->set_time_zone($timezone); + my $wday = $dt->day_of_week(); + if ($wday == 7) { $wday = 0; } + return ( 'second' => $dt->second(), + 'minute' => $dt->minute(), + 'hour' => $dt->hour(), + 'day' => $dt->day_of_month(), + 'month' => $dt->month(), + 'year' => $dt->year(), + 'weekday' => $wday, + 'dayyear' => $dt->day_of_year(), + 'dlsav' => $dt->is_dst() ); } sub utc_string { @@ -2786,6 +3521,24 @@ sub utc_string { sub maketime { my %th=@_; + my ($epoch_time,$timezone,$dt); + $timezone = &Apache::lonlocal::gettimezone(); + eval { + $dt = DateTime->new( year => $th{'year'}, + month => $th{'month'}, + day => $th{'day'}, + hour => $th{'hour'}, + minute => $th{'minute'}, + second => $th{'second'}, + time_zone => $timezone, + ); + }; + if (!$@) { + $epoch_time = $dt->epoch; + if ($epoch_time) { + return $epoch_time; + } + } return POSIX::mktime( ($th{'seconds'},$th{'minutes'},$th{'hours'}, $th{'day'},$th{'month'}-1,$th{'year'}-1900,0,0,-1)); @@ -3136,7 +3889,7 @@ sub blocking_status { &Apache::lonnet::coursedescription($course); $coursedesc = $courseinfo{'description'}; } - $category = "Group files in the course '$coursedesc'"; + $category = "Group portfolio files in the course '$coursedesc'"; } else { $category = 'Portfolio files belonging to '; if ($env{'user.name'} eq 'public' && @@ -3166,6 +3919,60 @@ sub blocking_status { ############################################### +sub check_ip_acc { + my ($acc)=@_; + &Apache::lonxml::debug("acc is $acc"); + if (!defined($acc) || $acc =~ /^\s*$/ || $acc =~/^\s*no\s*$/i) { + return 1; + } + my $allowed=0; + my $ip=$env{'request.host'} || $ENV{'REMOTE_ADDR'}; + + my $name; + foreach my $pattern (split(',',$acc)) { + $pattern =~ s/^\s*//; + $pattern =~ s/\s*$//; + if ($pattern =~ /\*$/) { + #35.8.* + $pattern=~s/\*//; + if ($ip =~ /^\Q$pattern\E/) { $allowed=1; } + } elsif ($pattern =~ /(\d+\.\d+\.\d+)\.\[(\d+)-(\d+)\]$/) { + #35.8.3.[34-56] + my $low=$2; + my $high=$3; + $pattern=$1; + if ($ip =~ /^\Q$pattern\E/) { + my $last=(split(/\./,$ip))[3]; + if ($last <=$high && $last >=$low) { $allowed=1; } + } + } elsif ($pattern =~ /^\*/) { + #*.msu.edu + $pattern=~s/\*//; + if (!defined($name)) { + use Socket; + my $netaddr=inet_aton($ip); + ($name)=gethostbyaddr($netaddr,AF_INET); + } + if ($name =~ /\Q$pattern\E$/i) { $allowed=1; } + } elsif ($pattern =~ /\d+\.\d+\.\d+\.\d+/) { + #127.0.0.1 + if ($ip =~ /^\Q$pattern\E/) { $allowed=1; } + } else { + #some.name.com + if (!defined($name)) { + use Socket; + my $netaddr=inet_aton($ip); + ($name)=gethostbyaddr($netaddr,AF_INET); + } + if ($name =~ /\Q$pattern\E$/i) { $allowed=1; } + } + if ($allowed) { last; } + } + return $allowed; +} + +############################################### + =pod =head1 Domain Template Functions @@ -3209,45 +4016,85 @@ sub get_domainconf { my %domconfig = &Apache::lonnet::get_dom('configuration', ['login','rolecolors'],$udom); - my %designhash; + my (%designhash,%legacy); if (keys(%domconfig) > 0) { if (ref($domconfig{'login'}) eq 'HASH') { - foreach my $key (keys(%{$domconfig{'login'}})) { - $designhash{$udom.'.login.'.$key}=$domconfig{'login'}{$key}; + if (keys(%{$domconfig{'login'}})) { + foreach my $key (keys(%{$domconfig{'login'}})) { + if (ref($domconfig{'login'}{$key}) eq 'HASH') { + foreach my $img (keys(%{$domconfig{'login'}{$key}})) { + $designhash{$udom.'.login.'.$key.'_'.$img} = + $domconfig{'login'}{$key}{$img}; + } + } else { + $designhash{$udom.'.login.'.$key}=$domconfig{'login'}{$key}; + } + } + } else { + $legacy{'login'} = 1; } + } else { + $legacy{'login'} = 1; } if (ref($domconfig{'rolecolors'}) eq 'HASH') { - foreach my $role (keys(%{$domconfig{'rolecolors'}})) { - if (ref($domconfig{'rolecolors'}{$role}) eq 'HASH') { - foreach my $item (keys(%{$domconfig{'rolecolors'}{$role}})) { - $designhash{$udom.'.'.$role.'.'.$item}=$domconfig{'rolecolors'}{$role}{$item}; + if (keys(%{$domconfig{'rolecolors'}})) { + foreach my $role (keys(%{$domconfig{'rolecolors'}})) { + if (ref($domconfig{'rolecolors'}{$role}) eq 'HASH') { + foreach my $item (keys(%{$domconfig{'rolecolors'}{$role}})) { + $designhash{$udom.'.'.$role.'.'.$item}=$domconfig{'rolecolors'}{$role}{$item}; + } } } + } else { + $legacy{'rolecolors'} = 1; } + } else { + $legacy{'rolecolors'} = 1; } - } else { - my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors'; - my $designfile = $designdir.'/'.$udom.'.tab'; - if (-e $designfile) { - if ( open (my $fh,"<$designfile") ) { - while (my $line = <$fh>) { - next if ($line =~ /^\#/); - chomp($line); - my ($key,$val)=(split(/\=/,$line)); - if ($val) { $designhash{$udom.'.'.$key}=$val; } + if (keys(%legacy) > 0) { + my %legacyhash = &get_legacy_domconf($udom); + foreach my $item (keys(%legacyhash)) { + if ($item =~ /^\Q$udom\E\.login/) { + if ($legacy{'login'}) { + $designhash{$item} = $legacyhash{$item}; + } + } else { + if ($legacy{'rolecolors'}) { + $designhash{$item} = $legacyhash{$item}; + } } - close($fh); } } - if (-e '/home/httpd/html/adm/lonDomLogos/'.$udom.'.gif') { - $designhash{$udom.'.login.domlogo'} = "/adm/lonDomLogos/$udom.gif"; - } + } else { + %designhash = &get_legacy_domconf($udom); } &Apache::lonnet::do_cache_new('domainconfig',$udom,\%designhash, $cachetime); return %designhash; } +sub get_legacy_domconf { + my ($udom) = @_; + my %legacyhash; + my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors'; + my $designfile = $designdir.'/'.$udom.'.tab'; + if (-e $designfile) { + if ( open (my $fh,"<$designfile") ) { + while (my $line = <$fh>) { + next if ($line =~ /^\#/); + chomp($line); + my ($key,$val)=(split(/\=/,$line)); + if ($val) { $legacyhash{$udom.'.'.$key}=$val; } + } + close($fh); + } + } + if (-e '/home/httpd/html/adm/lonDomLogos/'.$udom.'.gif') { + $legacyhash{$udom.'.login.domlogo'} = "/adm/lonDomLogos/$udom.gif"; + } + return %legacyhash; +} + =pod =item * &domainlogo() @@ -3297,10 +4144,10 @@ Returns: value of designparamter $which sub designparm { my ($which,$domain)=@_; if ($env{'browser.blackwhite'} eq 'on') { - if ($which=~/\.(font|alink|vlink|link)$/) { + if ($which=~/\.(font|alink|vlink|link|textcol)$/) { return '#000000'; } - if ($which=~/\.(pgbg|sidebg)$/) { + if ($which=~/\.(pgbg|sidebg|bgcol)$/) { return '#FFFFFF'; } if ($which=~/\.tabbg$/) { @@ -3319,7 +4166,7 @@ sub designparm { $output = $defaultdesign{$which}; } if (($which =~ /^(student|coordinator|author|admin)\.img$/) || - ($which =~ /login\.(img|logo|domlogo)/)) { + ($which =~ /login\.(img|logo|domlogo|login)/)) { if ($output =~ m{^/(adm|res)/}) { if ($output =~ m{^/res/}) { my $local_name = &Apache::lonnet::filelocation('',$output); @@ -3338,7 +4185,7 @@ sub designparm { =back -=head1 HTTP Helpers +=head1 HTML Helpers =over 4 @@ -3379,6 +4226,9 @@ Inputs: =item * $args, optional argument valid values are no_auto_mt_title -> prevents &mt()ing the title arg + inherit_jsmath -> when creating popup window in a page, + should it have jsmath forced on by the + current page =back @@ -3400,7 +4250,7 @@ sub bodytag { my $font = &designparm($function.'.font',$domain); my $pgbg = $bgcolor || &designparm($function.'.pgbg',$domain); - my %design = ( 'style' => 'margin-top: 0px', + my %design = ( 'style' => 'margin-top: 0', 'bgcolor' => $pgbg, 'text' => $font, 'alink' => &designparm($function.'.alink',$domain), @@ -3427,15 +4277,12 @@ sub bodytag { if (!$realm) { $realm=' '; } # Set messages my $messages=&domainlogo($domain); -# Port for miniserver - my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'}; - if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; } my $extra_body_attr = &make_attr_string($forcereg,\%design); # construct main body tag my $bodytag = "". - &Apache::lontexconvert::init_math_support(); + &Apache::lontexconvert::init_math_support($args->{'inherit_jsmath'}); if ($bodyonly) { return $bodytag; @@ -3487,7 +4334,7 @@ ENDROLE $dc_info = '('.$dc_info.')'; } - if ($env{'environment.remote'} eq 'off') { + if (($env{'environment.remote'} eq 'off') || ($args->{'suppress_header_logos'})) { # No Remote if ($env{'request.state'} eq 'construct') { $forcereg=1; @@ -3510,9 +4357,9 @@ ENDROLE $lastitem = $thisdisfn; } $titleinfo = - &Apache::loncommon::help_open_menu('','',3,'Authoring'). - 'Construction Space: '. - '
' .&Apache::lonhtmlcommon::crumbs($uname.'/'.$parentpath,'_top','/priv','','+1',1)."$lastitem
" .&Apache::lonhtmlcommon::select_recent('construct','recent','this.form.action=this.form.recent.value;this.form.submit()') @@ -3547,7 +4394,7 @@ ENDROLE my $imgsrc = $img; if ($img =~ /^\/adm/) { - $imgsrc = 'http://'.$ENV{'HTTP_HOST'}.':'.$lonhttpdPort.$img; + $imgsrc = &lonhttpdurl($img); } my $upperleft=''.$function.''; @@ -3632,38 +4479,35 @@ sub make_attr_string { =pod -=back - -=head1 HTML Helpers - -=over 4 - =item * &endbodytag() Returns a uniform footer for LON-CAPA web pages. -Inputs: none - -=back +Inputs: 1 - optional reference to an args hash +If in the hash, key for noredirectlink has a value which evaluates to true, +a 'Continue' link is not displayed if the page contains an +internal redirect in the section, +i.e., $env{'internal.head.redirect'} exists =cut sub endbodytag { + my ($args) = @_; my $endbodytag=''; $endbodytag=&Apache::lontexconvert::jsMath_process()."\n".$endbodytag; if ( exists( $env{'internal.head.redirect'} ) ) { - $endbodytag= - "
". - &mt('Continue').''. - $endbodytag; + if (!(ref($args) eq 'HASH' && $args->{'noredirectlink'})) { + $endbodytag= + "
". + &mt('Continue').''. + $endbodytag; + } } return $endbodytag; } =pod -=over 4 - =item * &standard_css() Returns a style sheet @@ -3674,8 +4518,6 @@ Inputs: (all optional) function -> force usage of a specific rolish color scheme bgcolor -> override the default page bgcolor -=back - =cut sub standard_css { @@ -3693,7 +4535,7 @@ sub standard_css { my $vlink = &designparm($function.'.vlink', $domain); my $link = &designparm($function.'.link', $domain); - my $sans = 'Arial,Helvetica,sans-serif'; + my $sans = 'Verdana,Arial,Helvetica,sans-serif'; my $mono = 'monospace'; my $data_table_head = $tabbg; my $data_table_light = '#EEEEEE'; @@ -3710,9 +4552,11 @@ sub standard_css { my $mail_other_hover = '#669999'; my $table_header = '#DDDDDD'; my $feedback_link_bg = '#BBBBBB'; + my $lg_border_color = '#C8C8C8'; - my $border = ($env{'browser.type'} eq 'explorer') ? '0px 2px 0px 2px' - : '0px 3px 0px 4px'; + my $border = ($env{'browser.type'} eq 'explorer' || + $env{'browser.type'} eq 'safari' ) ? '0 2px 0 2px' + : '0 3px 0 4px'; return < td { + background-color: #CCCCCC; + font-weight: bold; + text-align: left; +} +table.LC_data_table tr.LC_odd_row > td, +table.LC_pick_box tr > td.LC_odd_row, table.LC_aboutme_port tr td { background-color: $data_table_light; padding: 2px; } -table.LC_data_table tr.LC_even_row td, +table.LC_data_table tr.LC_even_row > td, +table.LC_pick_box tr > td.LC_even_row, table.LC_aboutme_port tr.LC_even_row td { background-color: $data_table_dark; + padding: 2px; } table.LC_data_table tr.LC_data_table_highlight td { background-color: $data_table_darker; } +table.LC_data_table tr td.LC_leftcol_header { + background-color: $data_table_head; + font-weight: bold; +} table.LC_data_table tr.LC_empty_row td, table.LC_nested tr.LC_empty_row td { background-color: #FFFFFF; @@ -4031,16 +4876,17 @@ table.LC_nested_outer tr td.LC_subheader text-align: right; } table.LC_nested tr.LC_info_row td { - background-color: #CCC; + background-color: #CCCCCC; font-weight: bold; font-size: small; text-align: center; } -table.LC_nested tr.LC_info_row td.LC_left_item { +table.LC_nested tr.LC_info_row td.LC_left_item, +table.LC_nested_outer tr th.LC_left_item { text-align: left; } table.LC_nested td { - background-color: #FFF; + background-color: #FFFFFF; font-size: small; } table.LC_nested_outer tr th.LC_right_item, @@ -4051,7 +4897,7 @@ table.LC_nested tr td.LC_right_item { } table.LC_nested tr.LC_odd_row td { - background-color: #EEE; + background-color: #EEEEEE; } table.LC_createuser { @@ -4062,7 +4908,7 @@ table.LC_createuser tr.LC_section_row td } table.LC_createuser tr.LC_info_row td { - background-color: #CCC; + background-color: #CCCCCC; font-weight: bold; text-align: center; } @@ -4118,10 +4964,10 @@ table.LC_mail_list tr.LC_mail_odd { table#LC_portfolio_actions { width: auto; background: $pgbg; - border: 0px; + border: none; border-spacing: 2px 2px; - padding: 0px; - margin: 0px; + padding: 0; + margin: 0; border-collapse: separate; } table#LC_portfolio_actions td.LC_label { @@ -4177,6 +5023,26 @@ table#LC_browser tr.LC_browser_file_meta table#LC_browser tr.LC_browser_folder { background: #CCCCFF; } + +table.LC_data_table tr > td.LC_roles_is { +/* background: #77FF77; */ +} +table.LC_data_table tr > td.LC_roles_future { + background: #FFFF77; +} +table.LC_data_table tr > td.LC_roles_will { + background: #FFAA77; +} +table.LC_data_table tr > td.LC_roles_expired { + background: #FF7777; +} +table.LC_data_table tr > td.LC_roles_will_not { + background: #AAFF77; +} +table.LC_data_table tr > td.LC_roles_selected { + background: #11CC55; +} + span.LC_current_location { font-size: x-large; background: $pgbg; @@ -4222,9 +5088,9 @@ table.LC_parm_overview_restrictions th { border-color: $pgbg; } table#LC_helpmenu { - border: 0px; + border: none; height: 55px; - border-spacing: 0px; + border-spacing: 0; } table#LC_helpmenu fieldset legend { @@ -4235,7 +5101,7 @@ table#LC_helpmenu_links { width: 100%; border: 1px solid black; background: $pgbg; - padding: 0px; + padding: 0; border-spacing: 1px; } table#LC_helpmenu_links tr td { @@ -4267,9 +5133,7 @@ table#LC_helpmenu_links a:hover { border: 1px solid #8888FF; background: #CCCCFF; } - table.LC_pick_box { - width: 100%; border-collapse: separate; background: white; border: 1px solid black; @@ -4279,18 +5143,76 @@ table.LC_pick_box td.LC_pick_box_title { background: $tabbg; font-weight: bold; text-align: right; + vertical-align: top; width: 184px; padding: 8px; } +table.LC_pick_box td.LC_selfenroll_pick_box_title { + background: $tabbg; + font-weight: bold; + text-align: right; + width: 350px; + padding: 8px; +} + +table.LC_pick_box td.LC_pick_box_value { + text-align: left; + padding: 8px; +} +table.LC_pick_box td.LC_pick_box_select { + text-align: left; + padding: 8px; +} table.LC_pick_box td.LC_pick_box_separator { - padding: 0px; + padding: 0; height: 1px; background: black; } table.LC_pick_box td.LC_pick_box_submit { text-align: right; } - +table.LC_pick_box td.LC_evenrow_value { + text-align: left; + padding: 8px; + background-color: $data_table_light; +} +table.LC_pick_box td.LC_oddrow_value { + text-align: left; + padding: 8px; + background-color: $data_table_light; +} +table.LC_helpform_receipt { + width: 620px; + border-collapse: separate; + background: white; + border: 1px solid black; + border-spacing: 1px; +} +table.LC_helpform_receipt td.LC_pick_box_title { + background: $tabbg; + font-weight: bold; + text-align: right; + width: 184px; + padding: 8px; +} +table.LC_helpform_receipt td.LC_evenrow_value { + text-align: left; + padding: 8px; + background-color: $data_table_light; +} +table.LC_helpform_receipt td.LC_oddrow_value { + text-align: left; + padding: 8px; + background-color: $data_table_light; +} +table.LC_helpform_receipt td.LC_pick_box_separator { + padding: 0; + height: 1px; + background: black; +} +span.LC_helpform_receipt_cat { + font-weight: bold; +} table.LC_group_priv_box { background: white; border: 1px solid black; @@ -4317,7 +5239,7 @@ table.LC_group_priv_box td.LC_groups_fun } table.LC_group_priv td { text-align: left; - padding: 0px; + padding: 0; } table.LC_notify_front_page { @@ -4338,6 +5260,7 @@ table.LC_notify_front_page td { background: $tabbg; vertical-align: middle; margin: 2ex 0ex 2ex 0ex; + padding: 3px; } .LC_topic_bar span { vertical-align: middle; @@ -4358,12 +5281,20 @@ table.LC_descriptive_input td.LC_descrip text-align: right; font-weight: bold; } -table.LC_feedback_link { - background: $feedback_link_bg; +div.LC_feedback_link { + clear: both; + background: white; + width: 100%; } span.LC_feedback_link { - background: $feedback_link_bg; - font-size: larger; + background: $feedback_link_bg; + font-size: larger; +} +span.LC_message_link { + background: $feedback_link_bg; + font-size: larger; + position: absolute; + right: 1em; } table.LC_prior_tries { @@ -4435,9 +5366,18 @@ span.LC_nobreak { white-space: nowrap; } +span.LC_cusr_emph { + font-style: italic; +} + +span.LC_cusr_subheading { + font-weight: normal; + font-size: 85%; +} + table.LC_docs_documents { background: #BBBBBB; - border-width: 0px; + border-width: 0; border-collapse: collapse; } @@ -4454,7 +5394,7 @@ table.LC_docs_documents td.LC_docs_docum } .LC_docs_entry_move { - border: 0px; + border: none; border-collapse: collapse; } @@ -4502,13 +5442,207 @@ table.LC_docs_adddocs th { background: #DDDDDD; } +table.LC_sty_begin { + background: #BBFFBB; +} +table.LC_sty_end { + background: #FFBBBB; +} + +table.LC_double_column { + border-width: 0; + border-collapse: collapse; + width: 100%; + padding: 2px; +} + +table.LC_double_column tr td.LC_left_col { + top: 2px; + left: 2px; + width: 47%; + vertical-align: top; +} + +table.LC_double_column tr td.LC_right_col { + top: 2px; + right: 2px; + width: 47%; + vertical-align: top; +} + +span.LC_role_level { + font-weight: bold; +} + +div.LC_left_float { + float: left; + padding-right: 5%; + padding-bottom: 4px; +} + +div.LC_clear_float_header { + padding-bottom: 2px; +} + +div.LC_clear_float_footer { + padding-top: 10px; + clear: both; +} + + +div.LC_grade_select_mode { + font-family: $sans; +} +div.LC_grade_select_mode div div { + margin: 5px; +} +div.LC_grade_select_mode_selector { + margin: 5px; + float: left; +} +div.LC_grade_select_mode_selector_header { + font: bold medium $sans; +} +div.LC_grade_select_mode_type { + clear: left; +} + +div.LC_grade_show_user { + margin-top: 20px; + border: 1px solid black; +} +div.LC_grade_user_name { + background: #DDDDEE; + border-bottom: 1px solid black; + font: bold large $sans; +} +div.LC_grade_show_user_odd_row div.LC_grade_user_name { + background: #DDEEDD; +} + +div.LC_grade_show_problem, +div.LC_grade_submissions, +div.LC_grade_message_center, +div.LC_grade_info_links, +div.LC_grade_assign { + margin: 5px; + width: 99%; + background: #FFFFFF; +} +div.LC_grade_show_problem_header, +div.LC_grade_submissions_header, +div.LC_grade_message_center_header, +div.LC_grade_assign_header { + font: bold large $sans; +} +div.LC_grade_show_problem_problem, +div.LC_grade_submissions_body, +div.LC_grade_message_center_body, +div.LC_grade_assign_body { + border: 1px solid black; + width: 99%; + background: #FFFFFF; +} +span.LC_grade_check_note { + font: normal medium $sans; + display: inline; + position: absolute; + right: 1em; +} + +table.LC_scantron_action { + width: 100%; +} +table.LC_scantron_action tr th { + font: normal bold $sans; +} + +div.LC_edit_problem_header, +div.LC_edit_problem_footer { + font: normal medium $sans; + margin: 2px; +} +div.LC_edit_problem_header, +div.LC_edit_problem_header div, +div.LC_edit_problem_footer, +div.LC_edit_problem_footer div, +div.LC_edit_problem_editxml_header, +div.LC_edit_problem_editxml_header div { + margin-top: 5px; +} +div.LC_edit_problem_header_edit_row { + background: $tabbg; + padding: 3px; + margin-bottom: 5px; +} +div.LC_edit_problem_header_title { + font: larger bold $sans; + background: $tabbg; + padding: 3px; +} +table.LC_edit_problem_header_title { + font: larger bold $sans; + width: 100%; + border-color: $pgbg; + border-style: solid; + border-width: $border; + + background: $tabbg; + border-collapse: collapse; + padding: 0; +} + +div.LC_edit_problem_discards { + float: left; + padding-bottom: 5px; +} +div.LC_edit_problem_saves { + float: right; + padding-bottom: 5px; +} +hr.LC_edit_problem_divide { + clear: both; + color: $tabbg; + background-color: $tabbg; + height: 3px; + border: none; +} +img.stift{ + border-width:0; + vertical-align:middle; +} + +table#LC_mainmenu{ + margin-top:10px; + width:80%; + +} + +table#LC_mainmenu td.LC_mainmenu_col_fieldset{ + vertical-align: top; + width: 45%; +} +.LC_mainmenu_fieldset_category { + color: $font; + background: $pgbg; + font-family: $sans; + font-size: small; + font-weight: bold; +} +fieldset#LC_mainmenu_fieldset { + margin:0 10px 10px 0; + +} + +div.LC_createcourse { + margin: 10px 10px 10px 10px; +} + END } =pod -=over 4 - =item * &headtag() Returns a uniform footer for LON-CAPA web pages. @@ -4532,8 +5666,6 @@ Inputs: $title - optional title for the no_auto_mt_title -> prevent &mt()ing the title arg -=back - =cut sub headtag { @@ -4589,24 +5721,17 @@ ADDMETA =pod -=over 4 - =item * &font_settings() Returns neccessary to set the proper encoding Inputs: none -=back - =cut sub font_settings { my $headerstring=''; - if (($env{'browser.os'} eq 'mac') && (!$env{'browser.mathml'})) { - $headerstring.= - ''; - } elsif (!$env{'browser.mathml'} && $env{'browser.unicode'}) { + if (!$env{'browser.mathml'} && $env{'browser.unicode'}) { $headerstring.= ''; } @@ -4615,22 +5740,20 @@ sub font_settings { =pod -=over 4 - =item * &xml_begin() Returns the needed doctype and Inputs: none -=back - =cut sub xml_begin { my $output=''; - &Apache::lonhtmlcommon::init_htmlareafields(); + if ($env{'internal.start_page'}==1) { + &Apache::lonhtmlcommon::init_htmlareafields(); + } if ($env{'browser.mathml'}) { $output='' @@ -4649,16 +5772,12 @@ sub xml_begin { =pod -=over 4 - =item * &endheadtag() Returns a uniform for LON-CAPA web pages. Inputs: none -=back - =cut sub endheadtag { @@ -4667,14 +5786,17 @@ sub endheadtag { =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 +Inputs: + +=over 4 + +$title - optional title for the page + +$head_extra - optional extra HTML to put inside the =back @@ -4687,45 +5809,55 @@ sub head { =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 +Inputs: + +=over 4 + +$title - optional title for the page + +$head_extra - optional extra HTML to incude inside the + +$args - additional optional args supported are: + +=over 8 + + 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 + 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 + 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 + 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 + html_encode -> return a string ready for being used in a html attribute - force_register -> if is true will turn on the &bodytag() + force_register -> if is true will turn on the &bodytag() $forcereg arg - body_title -> alternate text to use instead of $title + 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 + frameset -> if true will start with a rather than - no_title -> if true the title bar won't be shown - skip_phases -> hash ref of + no_title -> if true the title bar won't be shown + skip_phases -> hash ref of head -> skip the generation body -> skip all generation - - no_inline_link -> if true and in remote mode, don't show the + no_inline_link -> if true and in remote mode, don't show the 'Switch To Inline Menu' link + no_auto_mt_title -> prevent &mt()ing the title arg + inherit_jsmath -> when creating popup window in a page, + should it have jsmath forced on by the + current page - no_auto_mt_title -> prevent &mt()ing the title arg +=back =back @@ -4774,14 +5906,28 @@ sub start_page { if ($args->{'html_encode'}) { $result = &html_encode($result); } + #Breadcrumbs + if (exists($args->{'bread_crumbs'}) or exists($args->{'bread_crumbs_component'})) { + &Apache::lonhtmlcommon::clear_breadcrumbs(); + #if any br links exists, add them to the breadcrumbs + if (exists($args->{'bread_crumbs'}) and ref($args->{'bread_crumbs'}) eq 'ARRAY') { + foreach my $crumb (@{$args->{'bread_crumbs'}}){ + &Apache::lonhtmlcommon::add_breadcrumb($crumb); + } + } + + #if bread_crumbs_component exists show it as headline else show only the breadcrumbs + if (exists($args->{'bread_crumbs_component'})){ + $result .= &Apache::lonhtmlcommon::breadcrumbs($args->{'bread_crumbs_component'}); + } else { + $result .= &Apache::lonhtmlcommon::breadcrumbs(); + } + } return $result; } - =pod -=over 4 - =item * &head() Returns a complete section for LON-CAPA web pages. @@ -4817,7 +5963,7 @@ sub end_page { if ($args->{'frameset'}) { $result .= ''; } else { - $result .= &endbodytag(); + $result .= &endbodytag($args); } $result .= "\n"; @@ -4889,30 +6035,30 @@ sub simple_error_page { } { - my $row_count; + my @row_count; sub start_data_table { my ($add_class) = @_; my $css_class = (join(' ','LC_data_table',$add_class)); - undef($row_count); + unshift(@row_count,0); return ''."\n"; } sub end_data_table { - undef($row_count); + shift(@row_count); return '
'."\n";; } sub start_data_table_row { my ($add_class) = @_; - $row_count++; - my $css_class = ($row_count % 2)?'':'LC_even_row'; + $row_count[0]++; + my $css_class = ($row_count[0] % 2)?'LC_odd_row':'LC_even_row'; $css_class = (join(' ',$css_class,$add_class)); return ''."\n";; } sub continue_data_table_row { my ($add_class) = @_; - my $css_class = ($row_count % 2)?'':'LC_even_row'; + my $css_class = ($row_count[0] % 2)?'LC_odd_row':'LC_even_row'; $css_class = (join(' ',$css_class,$add_class)); return ''."\n";; } @@ -4922,7 +6068,7 @@ sub simple_error_page { } sub start_data_table_empty_row { - $row_count++; + $row_count[0]++; return ''."\n";; } @@ -4939,10 +6085,61 @@ sub simple_error_page { } } +=pod + +=item * &inhibit_menu_check($arg) + +Checks for a inhibitmenu state and generates output to preserve it + +Inputs: $arg - can be any of + - undef - in which case the return value is a string + to add into arguments list of a uri + - 'input' - in which case the return value is a HTML + field of type hidden to + preserve the value + - a url - in which case the return value is the url with + the neccesary cgi args added to preserve the + inhibitmenu state + - a ref to a url - no return value, but the string is + updated to include the neccessary cgi + args to preserve the inhibitmenu state + +=cut + +sub inhibit_menu_check { + my ($arg) = @_; + &get_unprocessed_cgi($ENV{'QUERY_STRING'}, ['inhibitmenu']); + if ($arg eq 'input') { + if ($env{'form.inhibitmenu'}) { + return ''; + } else { + return + } + } + if ($env{'form.inhibitmenu'}) { + if (ref($arg)) { + $$arg .= '?inhibitmenu='.$env{'form.inhibitmenu'}; + } elsif ($arg eq '') { + $arg .= 'inhibitmenu='.$env{'form.inhibitmenu'}; + } else { + $arg .= '?inhibitmenu='.$env{'form.inhibitmenu'}; + } + } + if (!ref($arg)) { + return $arg; + } +} + ############################################### =pod +=back + +=head1 User Information Routines + +=over 4 + =item * &get_users_function() Used by &bodytag to determine the current users primary role. @@ -4970,6 +6167,37 @@ sub get_users_function { =pod +=item * &show_course() + +Used by lonmenu.pm and lonroles.pm to determine whether to use the word +'Courses' or 'Roles' in inline navigation and on screen displaying user's roles. +Inputs: +None + +Outputs: +Scalar: 1 if 'Course' to be used, 0 otherwise. + +=cut + +############################################### +sub show_course { + my $course = !$env{'user.adv'}; + if (!$env{'user.adv'}) { + foreach my $env (keys(%env)) { + next if ($env !~ m/^user\.priv\./); + if ($env !~ m/^user\.priv\.(?:st|cm)/) { + $course = 0; + last; + } + } + } + return $course; +} + +############################################### + +=pod + =item * &check_user_status() Determines current status of supplied role for a @@ -5143,12 +6371,17 @@ previous, future, or all. 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. +8. reference to optional statushash +9. flag if privileged users (except those set to unhide in + course settings) should be excluded +Keys of top level results 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. +Optional statushash returns + Entries for end, start, section and status are blank because of the possibility of multiple values for non-student roles. @@ -5157,7 +6390,7 @@ of the possibility of multiple values fo ############################################### sub get_course_users { - my ($cdom,$cnum,$types,$roles,$sections,$users,$userdata) = @_; + my ($cdom,$cnum,$types,$roles,$sections,$users,$userdata,$statushash,$hidepriv) = @_; my %idx = (); my %seclists; @@ -5177,6 +6410,7 @@ sub get_course_users { my $match = 0; my $secmatch = 0; my $section = $$classlist{$student}[$idx{section}]; + my $status = $$classlist{$student}[$idx{status}]; if ($section eq '') { $section = 'none'; } @@ -5196,7 +6430,6 @@ sub get_course_users { next; } } - push(@{$seclists{$student}},$section); if (defined($$types{'active'})) { if ($$classlist{$student}[$idx{status}] eq 'Active') { push(@{$$users{st}{$student}},'active'); @@ -5204,25 +6437,46 @@ sub get_course_users { } } if (defined($$types{'previous'})) { - if ($$classlist{$student}[$idx{end}] <= $now) { + if ($$classlist{$student}[$idx{status}] eq 'Expired') { 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 '')) { + if ($$classlist{$student}[$idx{status}] eq 'Future') { push(@{$$users{st}{$student}},'future'); $match = 1; } } - if ($match && ref($userdata) eq 'HASH') { - $$userdata{$student} = $$classlist{$student}; + if ($match) { + push(@{$seclists{$student}},$section); + if (ref($userdata) eq 'HASH') { + $$userdata{$student} = $$classlist{$student}; + } + if (ref($statushash) eq 'HASH') { + $statushash->{$student}{'st'}{$section} = $status; + } } } } if ((@{$roles} > 1) || ((@{$roles} == 1) && ($$roles[0] ne "st"))) { my %coursepersonnel = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum); my $now = time; + my %displaystatus = ( previous => 'Expired', + active => 'Active', + future => 'Future', + ); + my %nothide; + if ($hidepriv) { + my %coursehash=&Apache::lonnet::coursedescription($cdom.'_'.$cnum); + foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) { + if ($user !~ /:/) { + $nothide{join(':',split(/[\@]/,$user))}=1; + } else { + $nothide{$user} = 1; + } + } + } foreach my $person (sort(keys(%coursepersonnel))) { my $match = 0; my $secmatch = 0; @@ -5256,6 +6510,12 @@ sub get_course_users { $usec = 'none'; } if ($uname ne '' && $udom ne '') { + if ($hidepriv) { + if ((&Apache::lonnet::privileged($uname,$udom)) && + (!$nothide{$uname.':'.$udom})) { + next; + } + } if ($end > 0 && $end < $now) { $status = 'previous'; } elsif ($start > $now) { @@ -5278,6 +6538,9 @@ sub get_course_users { if (!grep(/^\Q$usec\E$/,@{$seclists{$uname.':'.$udom}})) { push(@{$seclists{$uname.':'.$udom}},$usec); } + if (ref($statushash) eq 'HASH') { + $statushash->{$uname.':'.$udom}{$role}{$usec} = $displaystatus{$status}; + } } } } @@ -5287,15 +6550,25 @@ sub get_course_users { my %csettings = &Apache::lonnet::get('environment',['internal.courseowner'],$cdom,$cnum); if ( defined($csettings{'internal.courseowner'}) ) { my $owner = $csettings{'internal.courseowner'}; - if ($owner !~ /^[^:]+:[^:]+$/) { - $owner = $owner.':'.$cdom; + next if ($owner eq ''); + my ($ownername,$ownerdom); + if ($owner =~ /^([^:]+):([^:]+)$/) { + $ownername = $1; + $ownerdom = $2; + } else { + $ownername = $owner; + $ownerdom = $cdom; + $owner = $ownername.':'.$ownerdom; } @{$$users{'ow'}{$owner}} = 'any'; if (defined($userdata) && - !exists($$userdata{$owner.':'.$cdom})) { - &get_user_info($cdom,$owner,\%idx,$userdata); - if (!grep(/^none$/,@{$seclists{$owner.':'.$cdom}})) { - push(@{$seclists{$owner.':'.$cdom}},'none'); + !exists($$userdata{$owner})) { + &get_user_info($ownerdom,$ownername,\%idx,$userdata); + if (!grep(/^none$/,@{$seclists{$owner}})) { + push(@{$seclists{$owner}},'none'); + } + if (ref($statushash) eq 'HASH') { + $statushash->{$owner}{'ow'}{'none'} = 'Any'; } } } @@ -5315,6 +6588,8 @@ sub get_user_info { &plainname($uname,$udom,'lastname'); $$userdata{$uname.':'.$udom}[$$idx{uname}] = $uname; $$userdata{$uname.':'.$udom}[$$idx{udom}] = $udom; + my %idhash = &Apache::lonnet::idrget($udom,($uname)); + $$userdata{$uname.':'.$udom}[$$idx{id}] = $idhash{$uname}; return; } @@ -5435,24 +6710,40 @@ sub default_quota { my ($udom,$inststatus) = @_; my ($defquota,$settingstatus); my %quotahash = &Apache::lonnet::get_dom('configuration', - ['quota'],$udom); - if (ref($quotahash{'quota'}) eq 'HASH') { + ['quotas'],$udom); + if (ref($quotahash{'quotas'}) eq 'HASH') { if ($inststatus ne '') { - my @statuses = split(/:/,$inststatus); + my @statuses = map { &unescape($_); } split(/:/,$inststatus); foreach my $item (@statuses) { - if ($quotahash{'quota'}{$item} ne '') { - if ($defquota eq '') { - $defquota = $quotahash{'quota'}{$item}; - $settingstatus = $item; - } elsif ($quotahash{'quota'}{$item} > $defquota) { - $defquota = $quotahash{'quota'}{$item}; - $settingstatus = $item; + if (ref($quotahash{'quotas'}{'defaultquota'}) eq 'HASH') { + if ($quotahash{'quotas'}{'defaultquota'}{$item} ne '') { + if ($defquota eq '') { + $defquota = $quotahash{'quotas'}{'defaultquota'}{$item}; + $settingstatus = $item; + } elsif ($quotahash{'quotas'}{'defaultquota'}{$item} > $defquota) { + $defquota = $quotahash{'quotas'}{'defaultquota'}{$item}; + $settingstatus = $item; + } + } + } else { + if ($quotahash{'quotas'}{$item} ne '') { + if ($defquota eq '') { + $defquota = $quotahash{'quotas'}{$item}; + $settingstatus = $item; + } elsif ($quotahash{'quotas'}{$item} > $defquota) { + $defquota = $quotahash{'quotas'}{$item}; + $settingstatus = $item; + } } } } } if ($defquota eq '') { - $defquota = $quotahash{'quota'}{'default'}; + if (ref($quotahash{'quotas'}{'defaultquota'}) eq 'HASH') { + $defquota = $quotahash{'quotas'}{'defaultquota'}{'default'}; + } else { + $defquota = $quotahash{'quotas'}{'default'}; + } $settingstatus = 'default'; } } else { @@ -5503,9 +6794,520 @@ sub get_secgrprole_info { return (\@sections,\@groups,$allroles,$rolehash,$accesshash); } +sub user_picker { + my ($dom,$srch,$forcenewuser,$caller,$cancreate,$usertype) = @_; + my $currdom = $dom; + my %curr_selected = ( + srchin => 'dom', + srchby => 'lastname', + ); + my $srchterm; + if ((ref($srch) eq 'HASH') && ($env{'form.origform'} ne 'crtusername')) { + if ($srch->{'srchby'} ne '') { + $curr_selected{'srchby'} = $srch->{'srchby'}; + } + if ($srch->{'srchin'} ne '') { + $curr_selected{'srchin'} = $srch->{'srchin'}; + } + if ($srch->{'srchtype'} ne '') { + $curr_selected{'srchtype'} = $srch->{'srchtype'}; + } + if ($srch->{'srchdomain'} ne '') { + $currdom = $srch->{'srchdomain'}; + } + $srchterm = $srch->{'srchterm'}; + } + my %lt=&Apache::lonlocal::texthash( + 'usr' => 'Search criteria', + 'doma' => 'Domain/institution to search', + 'uname' => 'username', + 'lastname' => 'last name', + 'lastfirst' => 'last name, first name', + 'crs' => 'in this course', + 'dom' => 'in selected LON-CAPA domain', + 'alc' => 'all LON-CAPA', + 'instd' => 'in institutional directory for selected domain', + 'exact' => 'is', + 'contains' => 'contains', + 'begins' => 'begins with', + 'youm' => "You must include some text to search for.", + 'thte' => "The text you are searching for must contain at least two characters when using a 'begins' type search.", + 'thet' => "The text you are searching for must contain at least three characters when using a 'contains' type search.", + 'yomc' => "You must choose a domain when using an institutional directory search.", + 'ymcd' => "You must choose a domain when using a domain search.", + 'whus' => "When using searching by last,first you must include a comma as separator between last name and first name.", + 'whse' => "When searching by last,first you must include at least one character in the first name.", + 'thfo' => "The following need to be corrected before the search can be run:", + ); + my $domform = &select_dom_form($currdom,'srchdomain',1,1); + my $srchinsel = ' \n"; + + my $srchbysel = ' \n"; + + my $srchtypesel = ' \n"; + + my ($newuserscript,$new_user_create); + + if ($forcenewuser) { + if (ref($srch) eq 'HASH') { + if ($srch->{'srchby'} eq 'uname' && $srch->{'srchtype'} eq 'exact' && $srch->{'srchin'} eq 'dom' && $srch->{'srchdomain'} eq $env{'request.role.domain'}) { + if ($cancreate) { + $new_user_create = '

&"').'" onclick="javascript:setSearch(\'1\','.$caller.');" />

'; + } else { + my $helplink = 'javascript:helpMenu('."'display'".')'; + my %usertypetext = ( + official => 'institutional', + unofficial => 'non-institutional', + ); + $new_user_create = '

'. + &mt("You are not authorized to create new $usertypetext{$usertype} users in this domain.").' '. + &mt('Please contact the [_1]helpdesk[_2] for assistance.','','').'


'; + } + } + } + + $newuserscript = <<"ENDSCRIPT"; + +function setSearch(createnew,callingForm) { + if (createnew == 1) { + for (var i=0; i +function validateEntry(callingForm) { + + var checkok = 1; + var srchin; + for (var i=0; i + +$new_user_create + + + + + + + + + + + +
$lt{'doma'}:$domform
$lt{'usr'}:$srchbysel + $srchtypesel + + $srchinsel +
+
+END_BLOCK + + return $output; +} + +sub user_rule_check { + my ($usershash,$checks,$alerts,$rulematch,$inst_results,$curr_rules,$got_rules) = @_; + my $response; + if (ref($usershash) eq 'HASH') { + foreach my $user (keys(%{$usershash})) { + my ($uname,$udom) = split(/:/,$user); + next if ($udom eq '' || $uname eq ''); + my ($id,$newuser); + if (ref($usershash->{$user}) eq 'HASH') { + $newuser = $usershash->{$user}->{'newuser'}; + $id = $usershash->{$user}->{'id'}; + } + my $inst_response; + if (ref($checks) eq 'HASH') { + if (defined($checks->{'username'})) { + ($inst_response,%{$inst_results->{$user}}) = + &Apache::lonnet::get_instuser($udom,$uname); + } elsif (defined($checks->{'id'})) { + ($inst_response,%{$inst_results->{$user}}) = + &Apache::lonnet::get_instuser($udom,undef,$id); + } + } else { + ($inst_response,%{$inst_results->{$user}}) = + &Apache::lonnet::get_instuser($udom,$uname); + return; + } + if (!$got_rules->{$udom}) { + my %domconfig = &Apache::lonnet::get_dom('configuration', + ['usercreation'],$udom); + if (ref($domconfig{'usercreation'}) eq 'HASH') { + foreach my $item ('username','id') { + if (ref($domconfig{'usercreation'}{$item.'_rule'}) eq 'ARRAY') { + $$curr_rules{$udom}{$item} = + $domconfig{'usercreation'}{$item.'_rule'}; + } + } + } + $got_rules->{$udom} = 1; + } + foreach my $item (keys(%{$checks})) { + if (ref($$curr_rules{$udom}) eq 'HASH') { + if (ref($$curr_rules{$udom}{$item}) eq 'ARRAY') { + if (@{$$curr_rules{$udom}{$item}} > 0) { + my %rule_check = &Apache::lonnet::inst_rulecheck($udom,$uname,$id,$item,$$curr_rules{$udom}{$item}); + foreach my $rule (@{$$curr_rules{$udom}{$item}}) { + if ($rule_check{$rule}) { + $$rulematch{$user}{$item} = $rule; + if ($inst_response eq 'ok') { + if (ref($inst_results) eq 'HASH') { + if (ref($inst_results->{$user}) eq 'HASH') { + if (keys(%{$inst_results->{$user}}) == 0) { + $$alerts{$item}{$udom}{$uname} = 1; + } + } + } + } + last; + } + } + } + } + } + } + } + } + return; +} + +sub user_rule_formats { + my ($domain,$domdesc,$curr_rules,$check) = @_; + my %text = ( + 'username' => 'Usernames', + 'id' => 'IDs', + ); + my $output; + my ($rules,$ruleorder) = &Apache::lonnet::inst_userrules($domain,$check); + if ((ref($rules) eq 'HASH') && (ref($ruleorder) eq 'ARRAY')) { + if (@{$ruleorder} > 0) { + $output = '
'.&mt("$text{$check} with the following format(s) may only be used for verified users at [_1]:",$domdesc).'
    '; + foreach my $rule (@{$ruleorder}) { + if (ref($curr_rules) eq 'ARRAY') { + if (grep(/^\Q$rule\E$/,@{$curr_rules})) { + if (ref($rules->{$rule}) eq 'HASH') { + $output .= '
  • '.$rules->{$rule}{'name'}.': '. + $rules->{$rule}{'desc'}.'
    • '; + } + } + } + } + $output .= '
'; + } + } + return $output; +} + +sub instrule_disallow_msg { + my ($checkitem,$domdesc,$count,$mode) = @_; + my $response; + my %text = ( + item => 'username', + items => 'usernames', + match => 'matches', + do => 'does', + action => 'a username', + one => 'one', + ); + if ($count > 1) { + $text{'item'} = 'usernames'; + $text{'match'} ='match'; + $text{'do'} = 'do'; + $text{'action'} = 'usernames', + $text{'one'} = 'ones'; + } + if ($checkitem eq 'id') { + $text{'items'} = 'IDs'; + $text{'item'} = 'ID'; + $text{'action'} = 'an ID'; + if ($count > 1) { + $text{'item'} = 'IDs'; + $text{'action'} = 'IDs'; + } + } + $response = &mt("The $text{'item'} you chose $text{'match'} the format of $text{'items'} defined for [_1], but the $text{'item'} $text{'do'} not exist in the institutional directory.",''.$domdesc.'').'
'; + if ($mode eq 'upload') { + if ($checkitem eq 'username') { + $response .= &mt("You will need to modify your upload file so it will include $text{'action'} with a different format -- $text{'one'} that will not conflict with 'official' institutional $text{'items'}."); + } elsif ($checkitem eq 'id') { + $response .= &mt("Either upload a file which includes $text{'action'} with a different format -- $text{'one'} that will not conflict with 'official' institutional $text{'items'}, or when associating fields with data columns, omit an association for the Student/Employee ID field."); + } + } elsif ($mode eq 'selfcreate') { + if ($checkitem eq 'id') { + $response .= &mt("You must either choose $text{'action'} with a different format -- $text{'one'} that will not conflict with 'official' institutional $text{'items'}, or leave the ID field blank."); + } + } else { + if ($checkitem eq 'username') { + $response .= &mt("You must choose $text{'action'} with a different format -- $text{'one'} that will not conflict with 'official' institutional $text{'items'}."); + } elsif ($checkitem eq 'id') { + $response .= &mt("You must either choose $text{'action'} with a different format -- $text{'one'} that will not conflict with 'official' institutional $text{'items'}, or leave the ID field blank."); + } + } + return $response; +} + +sub personal_data_fieldtitles { + my %fieldtitles = &Apache::lonlocal::texthash ( + id => 'Student/Employee ID', + permanentemail => 'E-mail address', + lastname => 'Last Name', + firstname => 'First Name', + middlename => 'Middle Name', + generation => 'Generation', + gen => 'Generation', + inststatus => 'Affiliation', + ); + return %fieldtitles; +} + +sub sorted_inst_types { + my ($dom) = @_; + my ($usertypes,$order) = &Apache::lonnet::retrieve_inst_usertypes($dom); + my $othertitle = &mt('All users'); + if ($env{'request.course.id'}) { + $othertitle = &mt('Any users'); + } + my @types; + if (ref($order) eq 'ARRAY') { + @types = @{$order}; + } + if (@types == 0) { + if (ref($usertypes) eq 'HASH') { + @types = sort(keys(%{$usertypes})); + } + } + if (keys(%{$usertypes}) > 0) { + $othertitle = &mt('Other users'); + } + return ($othertitle,$usertypes,\@types); +} + +sub get_institutional_codes { + my ($settings,$allcourses,$LC_code) = @_; +# Get complete list of course sections to update + my @currsections = (); + my @currxlists = (); + my $coursecode = $$settings{'internal.coursecode'}; + + if ($$settings{'internal.sectionnums'} ne '') { + @currsections = split(/,/,$$settings{'internal.sectionnums'}); + } + + if ($$settings{'internal.crosslistings'} ne '') { + @currxlists = split(/,/,$$settings{'internal.crosslistings'}); + } + + if (@currxlists > 0) { + foreach (@currxlists) { + if (m/^([^:]+):(\w*)$/) { + unless (grep/^$1$/,@{$allcourses}) { + push @{$allcourses},$1; + $$LC_code{$1} = $2; + } + } + } + } + + if (@currsections > 0) { + foreach (@currsections) { + if (m/^(\w+):(\w*)$/) { + my $sec = $coursecode.$1; + my $lc_sec = $2; + unless (grep/^$sec$/,@{$allcourses}) { + push @{$allcourses},$sec; + $$LC_code{$sec} = $lc_sec; + } + } + } + } + return; +} + =pod -=item * get_unprocessed_cgi($query,$possible_names) +=head1 Slot Helpers + +=over 4 + +=item * sorted_slots() + +Sorts an array of slot names in order of slot start time (earliest first). + +Inputs: + +=over 4 + +slotsarr - Reference to array of unsorted slot names. + +slots - Reference to hash of hash, where outer hash keys are slot names. + +=back + +Returns: + +=over 4 + +sorted - An array of slot names sorted by the start time of the slot. + +=back + +=back + +=cut + + +sub sorted_slots { + my ($slotsarr,$slots) = @_; + my @sorted; + if ((ref($slotsarr) eq 'ARRAY') && (ref($slots) eq 'HASH')) { + @sorted = + sort { + if (ref($slots->{$a}) && ref($slots->{$b})) { + return $slots->{$a}{'starttime'} <=> $slots->{$b}{'starttime'} + } + if (ref($slots->{$a})) { return -1;} + if (ref($slots->{$b})) { return 1;} + return 0; + } @{$slotsarr}; + } + return @sorted; +} + +=pod + +=back + +=head1 HTTP Helpers + +=over 4 + +=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), @@ -5534,7 +7336,7 @@ sub get_unprocessed_cgi { =pod -=item * cacheheader() +=item * &cacheheader() returns cache-controlling header code @@ -5551,7 +7353,7 @@ sub cacheheader { =pod -=item * no_cache($r) +=item * &no_cache($r) specifies header code to not have cache @@ -5587,7 +7389,7 @@ sub content_type { =pod -=item * add_to_env($name,$value) +=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 @@ -5614,7 +7416,7 @@ sub add_to_env { =pod -=item * get_env_multiple($name) +=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. @@ -5637,6 +7439,232 @@ sub get_env_multiple { return(@values); } +sub ask_for_embedded_content { + my ($actionurl,$state,$allfiles,$codebase,$args)=@_; + my $upload_output = ' + '; + $upload_output .= $state; + $upload_output .= 'Upload embedded files:
'.&start_data_table(); + + my $num = 0; + foreach my $embed_file (sort {lc($a) cmp lc($b)} keys(%{$allfiles})) { + $upload_output .= &start_data_table_row(). + ''.$embed_file.''; + if ($args->{'ignore_remote_references'} + && $embed_file =~ m{^\w+://}) { + $upload_output.=''.&mt("URL points to other server.").''; + } elsif ($args->{'error_on_invalid_names'} + && $embed_file ne &Apache::lonnet::clean_filename($embed_file,{'keep_path' => 1,})) { + + $upload_output.=''.&mt("Invalid characters").''; + + } else { + $upload_output .=' + + '; + my $attrib = join(':',@{$$allfiles{$embed_file}}); + $upload_output .= + "\n\t\t". + ''; + if (exists($$codebase{$embed_file})) { + $upload_output .= + "\n\t\t". + ''; + } + } + $upload_output .= ''.&Apache::loncommon::end_data_table_row(); + $num++; + } + $upload_output .= &Apache::loncommon::end_data_table().'
+ + + '.&mt('(only files for which a location has been provided will be uploaded)').' + '; + return $upload_output; +} + +sub upload_embedded { + my ($context,$dirpath,$uname,$udom,$dir_root,$url_root,$group,$disk_quota, + $current_disk_usage) = @_; + my $output; + for (my $i=0; $i<$env{'form.number_embedded_items'}; $i++) { + next if (!exists($env{'form.embedded_item_'.$i.'.filename'})); + my $orig_uploaded_filename = + $env{'form.embedded_item_'.$i.'.filename'}; + + $env{'form.embedded_orig_'.$i} = + &unescape($env{'form.embedded_orig_'.$i}); + my ($path,$fname) = + ($env{'form.embedded_orig_'.$i} =~ m{(.*/)([^/]*)}); + # no path, whole string is fname + if (!$fname) { $fname = $env{'form.embedded_orig_'.$i} }; + + $path = $env{'form.currentpath'}.$path; + $fname = &Apache::lonnet::clean_filename($fname); + # See if there is anything left + next if ($fname eq ''); + + # Check if file already exists as a file or directory. + my ($state,$msg); + if ($context eq 'portfolio') { + my $port_path = $dirpath; + if ($group ne '') { + $port_path = "groups/$group/$port_path"; + } + ($state,$msg) = &check_for_upload($path,$fname,$group,'embedded_item_'.$i, + $dir_root,$port_path,$disk_quota, + $current_disk_usage,$uname,$udom); + if ($state eq 'will_exceed_quota' + || $state eq 'file_locked' + || $state eq 'file_exists' ) { + $output .= $msg; + next; + } + } elsif (($context eq 'author') || ($context eq 'testbank')) { + ($state,$msg) = &check_for_existing($path,$fname,'embedded_item_'.$i); + if ($state eq 'exists') { + $output .= $msg; + next; + } + } + # Check if extension is valid + if (($fname =~ /\.(\w+)$/) && + (&Apache::loncommon::fileembstyle($1) eq 'hdn')) { + $output .= &mt('Invalid file extension ([_1]) - reserved for LONCAPA use - rename the file with a different extension and re-upload. ',$1); + next; + } elsif (($fname =~ /\.(\w+)$/) && + (!defined(&Apache::loncommon::fileembstyle($1)))) { + $output .= &mt('Unrecognized file extension ([_1]) - rename the file with a proper extension and re-upload.',$1); + next; + } elsif ($fname=~/\.(\d+)\.(\w+)$/) { + $output .= &mt('File name not allowed - rename the file to remove the number immediately before the file extension([_1]) and re-upload.',$2); + next; + } + + $env{'form.embedded_item_'.$i.'.filename'}=$fname; + if ($context eq 'portfolio') { + my $result= + &Apache::lonnet::userfileupload('embedded_item_'.$i,'', + $dirpath.$path); + if ($result !~ m|^/uploaded/|) { + $output .= '' + .&mt('An error occurred ([_1]) while trying to upload [_2] for embedded element [_3].' + ,$result,$orig_uploaded_filename,$env{'form.embedded_orig_'.$i}) + .'
'; + next; + } else { + $output .= '

'.&mt('Uploaded [_1]',''. + $path.$fname.'').'

'; + } + } else { +# Save the file + my $target = $env{'form.embedded_item_'.$i}; + my $fullpath = $dir_root.$dirpath.'/'.$path; + my $dest = $fullpath.$fname; + my $url = $url_root.$dirpath.'/'.$path.$fname; + my @parts=split(/\//,$fullpath); + my $count; + my $filepath = $dir_root; + for ($count=4;$count<=$#parts;$count++) { + $filepath .= "/$parts[$count]"; + if ((-e $filepath)!=1) { + mkdir($filepath,0770); + } + } + my $fh; + if (!open($fh,'>'.$dest)) { + &Apache::lonnet::logthis('Failed to create '.$dest); + $output .= ''. + &mt('An error occurred while trying to upload [_1] for embedded element [_2].',$orig_uploaded_filename,$env{'form.embedded_orig_'.$i}). + '
'; + } else { + if (!print $fh $env{'form.embedded_item_'.$i}) { + &Apache::lonnet::logthis('Failed to write to '.$dest); + $output .= ''. + &mt('An error occurred while writing the file [_1] for embedded element [_2].',$orig_uploaded_filename,$env{'form.embedded_orig_'.$i}). + '
'; + } else { + if ($context eq 'testbank') { + $output .= &mt('Embedded file uploaded successfully:'). + ' '. + $orig_uploaded_filename.'
'; + } else { + $output .= ''. + &mt('View embedded file: [_1]',''. + $orig_uploaded_filename.'').'
'; + } + } + close($fh); + } + } + } + return $output; +} + +sub check_for_existing { + my ($path,$fname,$element) = @_; + my ($state,$msg); + if (-d $path.'/'.$fname) { + $state = 'exists'; + $msg = &mt('Unable to upload [_1]. A directory by that name was found in [_2].',''.$fname.'',$path); + } elsif (-e $path.'/'.$fname) { + $state = 'exists'; + $msg = &mt('Unable to upload [_1]. A file by that name was found in [_2].',''.$fname.'',$path); + } + if ($state eq 'exists') { + $msg = ''.$msg.'
'; + } + return ($state,$msg); +} + +sub check_for_upload { + my ($path,$fname,$group,$element,$portfolio_root,$port_path, + $disk_quota,$current_disk_usage,$uname,$udom) = @_; + my $filesize = (length($env{'form.'.$element})) / 1000; #express in k (1024?) + my $getpropath = 1; + my @dir_list = &Apache::lonnet::dirlist($portfolio_root.$path,$udom,$uname, + $getpropath); + my $found_file = 0; + my $locked_file = 0; + foreach my $line (@dir_list) { + my ($file_name)=split(/\&/,$line,2); + if ($file_name eq $fname){ + $file_name = $path.$file_name; + if ($group ne '') { + $file_name = $group.$file_name; + } + $found_file = 1; + if (&Apache::lonnet::is_locked($file_name,$udom,$uname) eq 'true') { + $locked_file = 1; + } + } + } + if (($current_disk_usage + $filesize) > $disk_quota){ + my $msg = ''. + &mt('Unable to upload [_1]. (size = [_2] kilobytes). Disk quota will be exceeded.',''.$fname.'',$filesize).''. + '
'.&mt('Disk quota is [_1] kilobytes. Your current disk usage is [_2] kilobytes.',$disk_quota,$current_disk_usage); + return ('will_exceed_quota',$msg); + } elsif ($found_file) { + if ($locked_file) { + my $msg = ''; + $msg .= &mt('Unable to upload [_1]. A locked file by that name was found in [_2].',''.$fname.'',''.$port_path.$env{'form.currentpath'}.''); + $msg .= '
'; + $msg .= &mt('You will be able to rename or delete existing [_1] after a grade has been assigned.',''.$fname.''); + return ('file_locked',$msg); + } else { + my $msg = ''; + $msg .= &mt('Unable to upload [_1]. A file by that name was found in [_2].',''.$fname.'',$port_path.$env{'form.currentpath'}); + $msg .= ''; + $msg .= '
'; + $msg .= &mt('To upload, rename or delete existing [_1] in [_2].',''.$fname.'', $port_path.$env{'form.currentpath'}); + return ('file_exists',$msg); + } + } +} + =pod @@ -5646,7 +7674,7 @@ sub get_env_multiple { =over 4 -=item * upfile_store($r) +=item * &upfile_store($r) Store uploaded file, $r should be the HTTP Request object, needs $env{'form.upfile'} @@ -5676,7 +7704,7 @@ sub upfile_store { =pod -=item * load_tmp_file($r) +=item * &load_tmp_file($r) Load uploaded file from tmp, $r should be the HTTP Request object, needs $env{'form.datatoken'}, @@ -5700,7 +7728,7 @@ sub load_tmp_file { =pod -=item * upfile_record_sep() +=item * &upfile_record_sep() Separate uploaded file into records returns array of records, @@ -5722,7 +7750,7 @@ sub upfile_record_sep { =pod -=item * record_sep($record) +=item * &record_sep($record) Separate a record into fields $record should be an item from the upfile_record_sep(), needs $env{'form.upfiletype'} @@ -5754,28 +7782,50 @@ sub record_sep { $i++; } } else { - my @allfields; + my $separator=','; if ($env{'form.upfiletype'} eq 'semisv') { - @allfields=split(/;/,$record,-1); - } else { - @allfields=split(/\,/,$record,-1); + $separator=';'; } 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++; +# the character we are looking for to indicate the end of a quote or a record + my $looking_for=$separator; +# do not add the characters to the fields + my $ignore=0; +# we just encountered a separator (or the beginning of the record) + my $just_found_separator=1; +# store the field we are working on here + my $field=''; +# work our way through all characters in record + foreach my $character ($record=~/(.)/g) { + if ($character eq $looking_for) { + if ($character ne $separator) { +# Found the end of a quote, again looking for separator + $looking_for=$separator; + $ignore=1; + } else { +# Found a separator, store away what we got + $components{&takeleft($i)}=$field; + $i++; + $just_found_separator=1; + $ignore=0; + $field=''; + } + next; + } +# single or double quotation marks after a separator indicate beginning of a quote +# we are now looking for the end of the quote and need to ignore separators + if ((($character eq '"') || ($character eq "'")) && ($just_found_separator)) { + $looking_for=$character; + next; + } +# ignore would be true after we reached the end of a quote + if ($ignore) { next; } + if (($just_found_separator) && ($character=~/\s/)) { next; } + $field.=$character; + $just_found_separator=0; } +# catch the very last entry, since we never encountered the separator + $components{&takeleft($i)}=$field; } return %components; } @@ -5785,7 +7835,7 @@ sub record_sep { =pod -=item * upfile_select_html() +=item * &upfile_select_html() Return HTML code to select a file from the users machine and specify the file type. @@ -5803,7 +7853,7 @@ sub upfile_select_html { # xml => &mt('HTML/XML'), ); my $Str = ''. - '
Type: '; foreach my $type (sort(keys(%Types))) { $Str .= '\n"; } @@ -5832,7 +7882,7 @@ sub get_samples { =pod -=item * csv_print_samples($r,$records) +=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 @@ -5844,22 +7894,23 @@ Apache Request ref, $records is an array ###################################################### sub csv_print_samples { my ($r,$records) = @_; - my $samples = &get_samples($records,3); + my $samples = &get_samples($records,5); - $r->print(&mt('Samples').'
'); + $r->print(&mt('Samples').'
'.&start_data_table(). + &start_data_table_header_row()); foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) { $r->print(''); } - $r->print(''); + $r->print(&end_data_table_header_row()); foreach my $hash (@$samples) { - $r->print(''); + $r->print(&start_data_table_row()); foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) { $r->print(''); } - $r->print(''); + $r->print(&end_data_table_row()); } - $r->print('
'.&mt('Column [_1]',($sample+1)).'
'); if (defined($$hash{$sample})) { $r->print($$hash{$sample}); } $r->print('

'."\n"); + $r->print(&end_data_table().'
'."\n"); } ###################################################### @@ -5867,7 +7918,7 @@ sub csv_print_samples { =pod -=item * csv_print_select_table($r,$records,$d) +=item * &csv_print_select_table($r,$records,$d) Prints a table to create associations between values and table columns. @@ -5884,12 +7935,13 @@ sub csv_print_select_table { my $i=0; my $samples = &get_samples($records,1); $r->print(&mt('Associate columns with student attributes.')."\n". - ''. + &start_data_table().&start_data_table_header_row(). ''. - ''."\n"); + ''. + &end_data_table_header_row()."\n"); foreach my $array_ref (@$d) { my ($value,$display,$defaultcol)=@{ $array_ref }; - $r->print(''); + $r->print(&start_data_table_row().''); $r->print(''."\n"); + $r->print(''.&end_data_table_row()."\n"); $i++; } + $r->print(&end_data_table()); $i--; return $i; } @@ -5911,7 +7964,7 @@ sub csv_print_select_table { =pod -=item * csv_samples_select_table($r,$records,$d) +=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. @@ -5927,12 +7980,15 @@ sub csv_samples_select_table { my ($r,$records,$d) = @_; my $i=0; # - my $samples = &get_samples($records,3); - $r->print('
'.&mt('Attribute').''.&mt('Column').'
'.&mt('Column').'
'.$display.''.$display.'
'); + my $max_samples = 5; + my $samples = &get_samples($records,$max_samples); + $r->print(&start_data_table(). + &start_data_table_header_row().''. + &end_data_table_header_row()); foreach my $key (sort(keys(%{ $samples->[0] }))) { - $r->print(''); + $r->print(''.&end_data_table_row()); $i++; } + $r->print(&end_data_table()); $i--; return($i); } @@ -5958,7 +8015,7 @@ sub csv_samples_select_table { =pod -=item clean_excel_name($name) +=item * &clean_excel_name($name) Returns a replacement for $name which does not contain any illegal characters. @@ -5977,7 +8034,7 @@ sub clean_excel_name { =pod -=item * check_if_partid_hidden($id,$symb,$udom,$uname) +=item * &check_if_partid_hidden($id,$symb,$udom,$uname) Returns either 1 or undef @@ -6018,7 +8075,7 @@ sub check_if_partid_hidden { =over 4 -=item get_cgi_id +=item * &get_cgi_id() Inputs: none @@ -6042,7 +8099,7 @@ sub get_cgi_id { =pod -=item DrawBarGraph +=item * &DrawBarGraph() Facilitates the plotting of data in a (stacked) bar graph. Puts plot definition data into the users environment in order for @@ -6177,7 +8234,7 @@ sub DrawBarGraph { $ValuesHash{$id.'.'.$key} = $value; } # - &Apache::lonnet::appenv(%ValuesHash); + &Apache::lonnet::appenv(\%ValuesHash); return ''; } @@ -6186,7 +8243,7 @@ sub DrawBarGraph { =pod -=item DrawXYGraph +=item * &DrawXYGraph() Facilitates the plotting of data in an XY graph. Puts plot definition data into the users environment in order for @@ -6267,7 +8324,7 @@ sub DrawXYGraph { $ValuesHash{$id.'.'.$key} = $value; } # - &Apache::lonnet::appenv(%ValuesHash); + &Apache::lonnet::appenv(\%ValuesHash); return ''; } @@ -6276,7 +8333,7 @@ sub DrawXYGraph { =pod -=item DrawXYYGraph +=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 @@ -6369,7 +8426,7 @@ sub DrawXYYGraph { $ValuesHash{$id.'.'.$key} = $value; } # - &Apache::lonnet::appenv(%ValuesHash); + &Apache::lonnet::appenv(\%ValuesHash); return ''; } @@ -6386,7 +8443,7 @@ Bad place for them but what the hell. =over 4 -=item &chartlink +=item * &chartlink() Returns a link to the chart for a specific student. @@ -6425,9 +8482,9 @@ sub chartlink { =over 4 -=item &restore_course_settings +=item * &restore_course_settings() -=item &store_course_settings +=item * &store_course_settings() Restores/Store indicated form parameters from the course environment. Will not overwrite existing values of the form parameters. @@ -6447,6 +8504,8 @@ a hash ref describing the data to be sto Returns: both routines return nothing +=back + =cut ####################################################### @@ -6499,7 +8558,7 @@ sub store_settings { 'got error:'.$put_result); } # Make sure these settings stick around in this session, too - &Apache::lonnet::appenv(%AppHash); + &Apache::lonnet::appenv(\%AppHash); return; } @@ -6527,16 +8586,429 @@ sub restore_settings { } } +####################################################### +####################################################### + +=pod + +=head1 Domain E-mail Routines + +=over 4 + +=item * &build_recipient_list() + +Build recipient lists for four types of e-mail: +(a) Error Reports, (b) Package Updates, (c) lonstatus warnings/errors +(d) Help requests, generated by +lonerrorhandler.pm, CHECKRPMS, loncron, and lonsupportreq.pm respectively. + +Inputs: +defmail (scalar - email address of default recipient), +mailing type (scalar - errormail, packagesmail, or helpdeskmail), +defdom (domain for which to retrieve configuration settings), +origmail (scalar - email address of recipient from loncapa.conf, +i.e., predates configuration by DC via domainprefs.pm + +Returns: comma separated list of addresses to which to send e-mail. + +=back + +=cut + +############################################################ +############################################################ +sub build_recipient_list { + my ($defmail,$mailing,$defdom,$origmail) = @_; + my @recipients; + my $otheremails; + my %domconfig = + &Apache::lonnet::get_dom('configuration',['contacts'],$defdom); + if (ref($domconfig{'contacts'}) eq 'HASH') { + if (exists($domconfig{'contacts'}{$mailing})) { + if (ref($domconfig{'contacts'}{$mailing}) eq 'HASH') { + my @contacts = ('adminemail','supportemail'); + foreach my $item (@contacts) { + if ($domconfig{'contacts'}{$mailing}{$item}) { + my $addr = $domconfig{'contacts'}{$item}; + if (!grep(/^\Q$addr\E$/,@recipients)) { + push(@recipients,$addr); + } + } + $otheremails = $domconfig{'contacts'}{$mailing}{'others'}; + } + } + } elsif ($origmail ne '') { + push(@recipients,$origmail); + } + } elsif ($origmail ne '') { + push(@recipients,$origmail); + } + if (defined($defmail)) { + if ($defmail ne '') { + push(@recipients,$defmail); + } + } + if ($otheremails) { + my @others; + if ($otheremails =~ /,/) { + @others = split(/,/,$otheremails); + } else { + push(@others,$otheremails); + } + foreach my $addr (@others) { + if (!grep(/^\Q$addr\E$/,@recipients)) { + push(@recipients,$addr); + } + } + } + my $recipientlist = join(',',@recipients); + return $recipientlist; +} + ############################################################ ############################################################ +=pod + +=head1 Course Catalog Routines + +=over 4 + +=item * &gather_categories() + +Converts category definitions - keys of categories hash stored in +coursecategories in configuration.db on the primary library server in a +domain - to an array. Also generates javascript and idx hash used to +generate Domain Coordinator interface for editing Course Categories. + +Inputs: + +categories (reference to hash of category definitions). + +cats (reference to array of arrays/hashes which encapsulates hierarchy of + categories and subcategories). + +idx (reference to hash of counters used in Domain Coordinator interface for + editing Course Categories). + +jsarray (reference to array of categories used to create Javascript arrays for + Domain Coordinator interface for editing Course Categories). + +Returns: nothing + +Side effects: populates cats, idx and jsarray. + +=cut + +sub gather_categories { + my ($categories,$cats,$idx,$jsarray) = @_; + my %counters; + my $num = 0; + foreach my $item (keys(%{$categories})) { + my ($cat,$container,$depth) = map { &unescape($_); } split(/:/,$item); + if ($container eq '' && $depth == 0) { + $cats->[$depth][$categories->{$item}] = $cat; + } else { + $cats->[$depth]{$container}[$categories->{$item}] = $cat; + } + my ($escitem,$tail) = split(/:/,$item,2); + if ($counters{$tail} eq '') { + $counters{$tail} = $num; + $num ++; + } + if (ref($idx) eq 'HASH') { + $idx->{$item} = $counters{$tail}; + } + if (ref($jsarray) eq 'ARRAY') { + push(@{$jsarray->[$counters{$tail}]},$item); + } + } + return; +} + +=pod + +=item * &extract_categories() + +Used to generate breadcrumb trails for course categories. + +Inputs: + +categories (reference to hash of category definitions). + +cats (reference to array of arrays/hashes which encapsulates hierarchy of + categories and subcategories). + +trails (reference to array of breacrumb trails for each category). + +allitems (reference to hash - key is category key + (format: escaped(name):escaped(parent category):depth in hierarchy). + +idx (reference to hash of counters used in Domain Coordinator interface for + editing Course Categories). + +jsarray (reference to array of categories used to create Javascript arrays for + Domain Coordinator interface for editing Course Categories). + +subcats (reference to hash of arrays containing all subcategories within each + category, -recursive) + +Returns: nothing + +Side effects: populates trails and allitems hash references. + +=cut + +sub extract_categories { + my ($categories,$cats,$trails,$allitems,$idx,$jsarray,$subcats) = @_; + if (ref($categories) eq 'HASH') { + &gather_categories($categories,$cats,$idx,$jsarray); + if (ref($cats->[0]) eq 'ARRAY') { + for (my $i=0; $i<@{$cats->[0]}; $i++) { + my $name = $cats->[0][$i]; + my $item = &escape($name).'::0'; + my $trailstr; + if ($name eq 'instcode') { + $trailstr = &mt('Official courses (with institutional codes)'); + } else { + $trailstr = $name; + } + if ($allitems->{$item} eq '') { + push(@{$trails},$trailstr); + $allitems->{$item} = scalar(@{$trails})-1; + } + my @parents = ($name); + if (ref($cats->[1]{$name}) eq 'ARRAY') { + for (my $j=0; $j<@{$cats->[1]{$name}}; $j++) { + my $category = $cats->[1]{$name}[$j]; + if (ref($subcats) eq 'HASH') { + push(@{$subcats->{$item}},&escape($category).':'.&escape($name).':1'); + } + &recurse_categories($cats,2,$category,$trails,$allitems,\@parents,$subcats); + } + } else { + if (ref($subcats) eq 'HASH') { + $subcats->{$item} = []; + } + } + } + } + } + return; +} + +=pod + +=item *&recurse_categories() + +Recursively used to generate breadcrumb trails for course categories. + +Inputs: + +cats (reference to array of arrays/hashes which encapsulates hierarchy of + categories and subcategories). + +depth (current depth in hierarchy of categories and sub-categories - 0 indexed). + +category (current course category, for which breadcrumb trail is being generated). + +trails (reference to array of breadcrumb trails for each category). + +allitems (reference to hash - key is category key + (format: escaped(name):escaped(parent category):depth in hierarchy). + +parents (array containing containers directories for current category, + back to top level). + +Returns: nothing + +Side effects: populates trails and allitems hash references + +=cut + +sub recurse_categories { + my ($cats,$depth,$category,$trails,$allitems,$parents,$subcats) = @_; + my $shallower = $depth - 1; + if (ref($cats->[$depth]{$category}) eq 'ARRAY') { + for (my $k=0; $k<@{$cats->[$depth]{$category}}; $k++) { + my $name = $cats->[$depth]{$category}[$k]; + my $item = &escape($category).':'.&escape($parents->[-1]).':'.$shallower; + my $trailstr = join(' -> ',(@{$parents},$category)); + if ($allitems->{$item} eq '') { + push(@{$trails},$trailstr); + $allitems->{$item} = scalar(@{$trails})-1; + } + my $deeper = $depth+1; + push(@{$parents},$category); + if (ref($subcats) eq 'HASH') { + my $subcat = &escape($name).':'.$category.':'.$depth; + for (my $j=@{$parents}; $j>=0; $j--) { + my $higher; + if ($j > 0) { + $higher = &escape($parents->[$j]).':'. + &escape($parents->[$j-1]).':'.$j; + } else { + $higher = &escape($parents->[$j]).'::'.$j; + } + push(@{$subcats->{$higher}},$subcat); + } + } + &recurse_categories($cats,$deeper,$name,$trails,$allitems,$parents, + $subcats); + pop(@{$parents}); + } + } else { + my $item = &escape($category).':'.&escape($parents->[-1]).':'.$shallower; + my $trailstr = join(' -> ',(@{$parents},$category)); + if ($allitems->{$item} eq '') { + push(@{$trails},$trailstr); + $allitems->{$item} = scalar(@{$trails})-1; + } + } + return; +} + +=pod + +=item *&assign_categories_table() + +Create a datatable for display of hierarchical categories in a domain, +with checkboxes to allow a course to be categorized. + +Inputs: + +cathash - reference to hash of categories defined for the domain (from + configuration.db) + +currcat - scalar with an & separated list of categories assigned to a course. + +Returns: $output (markup to be displayed) + +=cut + +sub assign_categories_table { + my ($cathash,$currcat) = @_; + my $output; + if (ref($cathash) eq 'HASH') { + my (@cats,@trails,%allitems,%idx,@jsarray,@path,$maxdepth); + &extract_categories($cathash,\@cats,\@trails,\%allitems,\%idx,\@jsarray); + $maxdepth = scalar(@cats); + if (@cats > 0) { + my $itemcount = 0; + if (ref($cats[0]) eq 'ARRAY') { + $output = &Apache::loncommon::start_data_table(); + my @currcategories; + if ($currcat ne '') { + @currcategories = split('&',$currcat); + } + for (my $i=0; $i<@{$cats[0]}; $i++) { + my $parent = $cats[0][$i]; + my $css_class = $itemcount%2?' class="LC_odd_row"':''; + next if ($parent eq 'instcode'); + my $item = &escape($parent).'::0'; + my $checked = ''; + if (@currcategories > 0) { + if (grep(/^\Q$item\E$/,@currcategories)) { + $checked = ' checked="checked" '; + } + } + $output .= ''; + my $depth = 1; + push(@path,$parent); + $output .= &assign_category_rows($itemcount,\@cats,$depth,$parent,\@path,\@currcategories); + pop(@path); + $output .= ''; + $itemcount ++; + } + $output .= &Apache::loncommon::end_data_table(); + } + } + } + return $output; +} + +=pod + +=item *&assign_category_rows() + +Create a datatable row for display of nested categories in a domain, +with checkboxes to allow a course to be categorized,called recursively. + +Inputs: + +itemcount - track row number for alternating colors + +cats - reference to array of arrays/hashes which encapsulates hierarchy of + categories and subcategories. + +depth - current depth in hierarchy of categories and sub-categories - 0 indexed. + +parent - parent of current category item + +path - Array containing all categories back up through the hierarchy from the + current category to the top level. + +currcategories - reference to array of current categories assigned to the course + +Returns: $output (markup to be displayed). + +=cut + +sub assign_category_rows { + my ($itemcount,$cats,$depth,$parent,$path,$currcategories) = @_; + my ($text,$name,$item,$chgstr); + if (ref($cats) eq 'ARRAY') { + my $maxdepth = scalar(@{$cats}); + if (ref($cats->[$depth]) eq 'HASH') { + if (ref($cats->[$depth]{$parent}) eq 'ARRAY') { + my $numchildren = @{$cats->[$depth]{$parent}}; + my $css_class = $itemcount%2?' class="LC_odd_row"':''; + $text .= ''; + } + } + } + return $text; +} + +############################################################ +############################################################ + + sub commit_customrole { - my ($udom,$uname,$url,$three,$four,$five,$start,$end) = @_; - my $output = &mt('Assigning custom role').' "'.$five.'" by '.$four.'@'.$three.' in '.$url. + my ($udom,$uname,$url,$three,$four,$five,$start,$end,$context) = @_; + my $output = &mt('Assigning custom role').' "'.$five.'" by '.$four.':'.$three.' in '.$url. ($start?', '.&mt('starting').' '.localtime($start):''). ($end?', ending '.localtime($end):'').': '. &Apache::lonnet::assigncustomrole( - $udom,$uname,$url,$three,$four,$five,$end,$start). + $udom,$uname,$url,$three,$four,$five,$end,$start,undef,undef,$context). '
'; return $output; } @@ -6553,8 +9025,8 @@ sub commit_standardrole { my $result = &commit_studentrole(\$logmsg,$udom,$uname,$url,$three,$start,$end, $one,$two,$sec,$context); if (($result =~ /^error/) || ($result eq 'not_in_class') || - ($result eq 'unknown_course')) { - $output = "Error: $result\n"; + ($result eq 'unknown_course') || ($result eq 'refused')) { + $output = $logmsg.' '.&mt('Error: ').$result."\n"; } else { $output = $logmsg.$linefeed.&mt('Assigning').' '.$three.' in '.$url. ($start?', '.&mt('starting').' '.localtime($start):''). @@ -6571,7 +9043,7 @@ sub commit_standardrole { $output = &mt('Assigning').' '.$three.' in '.$url. ($start?', '.&mt('starting').' '.localtime($start):''). ($end?', '.&mt('ending').' '.localtime($end):'').': '; - my $result = &Apache::lonnet::assignrole($udom,$uname,$url,$three,$end,$start); + my $result = &Apache::lonnet::assignrole($udom,$uname,$url,$three,$end,$start,'','',$context); if ($context eq 'auto') { $output .= $result.$linefeed; } else { @@ -6583,7 +9055,7 @@ sub commit_standardrole { sub commit_studentrole { my ($logmsg,$udom,$uname,$url,$three,$start,$end,$one,$two,$sec,$context) = @_; - my ($result,$linefeed); + my ($result,$linefeed,$oldsecurl,$newsecurl); if ($context eq 'auto') { $linefeed = "\n"; } else { @@ -6595,37 +9067,92 @@ sub commit_studentrole { my $secchange = 0; my $expire_role_result; my $modify_section_result; - unless ($oldsec eq '-1') { - unless ($sec eq $oldsec) { + if ($oldsec ne '-1') { + if ($oldsec ne $sec) { $secchange = 1; + my $now = time; my $uurl='/'.$cid; $uurl=~s/\_/\//g; if ($oldsec) { $uurl.='/'.$oldsec; } - $expire_role_result = &Apache::lonnet::assignrole($udom,$uname,$uurl,'st',time); + $oldsecurl = $uurl; + $expire_role_result = + &Apache::lonnet::assignrole($udom,$uname,$uurl,'st',$now,'','',$context); + if ($env{'request.course.sec'} ne '') { + if ($expire_role_result eq 'refused') { + my @roles = ('st'); + my @statuses = ('previous'); + my @roledoms = ($one); + my $withsec = 1; + my %roleshash = + &Apache::lonnet::get_my_roles($uname,$udom,'userroles', + \@statuses,\@roles,\@roledoms,$withsec); + if (defined ($roleshash{$two.':'.$one.':st:'.$oldsec})) { + my ($oldstart,$oldend) = + split(':',$roleshash{$two.':'.$one.':st:'.$oldsec}); + if ($oldend > 0 && $oldend <= $now) { + $expire_role_result = 'ok'; + } + } + } + } $result = $expire_role_result; } } if (($expire_role_result eq 'ok') || ($secchange == 0)) { - $modify_section_result = &Apache::lonnet::modify_student_enrollment($udom,$uname,undef,undef,undef,undef,undef,$sec,$end,$start,'','',$cid); + $modify_section_result = &Apache::lonnet::modify_student_enrollment($udom,$uname,undef,undef,undef,undef,undef,$sec,$end,$start,'','',$cid,'',$context); if ($modify_section_result =~ /^ok/) { if ($secchange == 1) { - $$logmsg .= "Section for $uname switched from old section: $oldsec to new section: $sec".$linefeed; + if ($sec eq '') { + $$logmsg .= &mt('Section for [_1] switched from (possibly expired) old section: [_2] to student role without a section.',$uname,$oldsec).$linefeed; + } else { + $$logmsg .= &mt('Section for [_1] switched from (possibly expired) old section: [_2] to new section: [_3].',$uname,$oldsec,$sec).$linefeed; + } } elsif ($oldsec eq '-1') { - $$logmsg .= "New student role for $uname in section $sec in course $cid".$linefeed; + if ($sec eq '') { + $$logmsg .= &mt('New student role without a section for [_1] in course [_2].',$uname,$cid).$linefeed; + } else { + $$logmsg .= &mt('New student role for [_1] in section [_2] in course [_3].',$uname,$sec,$cid).$linefeed; + } } else { - $$logmsg .= "Student $uname assigned to unchanged section $sec in course $cid".$linefeed; + if ($sec eq '') { + $$logmsg .= &mt('Student [_1] assigned to course [_2] without a section.',$uname,$cid).$linefeed; + } else { + $$logmsg .= &mt('Student [_1] assigned to section [_2] in course [_3].',$uname,$sec,$cid).$linefeed; + } } } else { - $$logmsg .= "Error when attempting section change for $uname from old section $oldsec to new section: $sec in course $cid -error: $modify_section_result".$linefeed; + if ($secchange) { + $$logmsg .= &mt('Error when attempting section change for [_1] from old section "[_2]" to new section: "[_3]" in course [_4] -error:',$uname,$oldsec,$sec,$cid).' '.$modify_section_result.$linefeed; + } else { + $$logmsg .= &mt('Error when attempting to modify role for [_1] for section: "[_2]" in course [_3] -error:',$uname,$sec,$cid).' '.$modify_section_result.$linefeed; + } } $result = $modify_section_result; } elsif ($secchange == 1) { - $$logmsg .= "Error when attempting to expire role for $uname in old section $oldsec in course $cid -error: $expire_role_result".$linefeed; + if ($oldsec eq '') { + $$logmsg .= &mt('Error when attempting to expire existing role without a section for [_1] in course [_3] -error: ',$uname,$cid).' '.$expire_role_result.$linefeed; + } else { + $$logmsg .= &mt('Error when attempting to expire existing role for [_1] in section [_2] in course [_3] -error: ',$uname,$oldsec,$cid).' '.$expire_role_result.$linefeed; + } + if ($expire_role_result eq 'refused') { + my $newsecurl = '/'.$cid; + $newsecurl =~ s/\_/\//g; + if ($sec ne '') { + $newsecurl.='/'.$sec; + } + if (&Apache::lonnet::allowed('cst',$newsecurl) && !(&Apache::lonnet::allowed('cst',$oldsecurl))) { + if ($sec eq '') { + $$logmsg .= &mt('Although your current role has privileges to add students to section "[_1]", you do not have privileges to modify existing enrollments unaffiliated with any section.',$sec).$linefeed; + } else { + $$logmsg .= &mt('Although your current role has privileges to add students to section "[_1]", you do not have privileges to modify existing enrollments in other sections.',$sec).$linefeed; + } + } + } } } else { - $$logmsg .= "Incomplete course id defined. Addition of user $uname from domain $udom to course $one\_$two, section $sec not completed.$linefeed"; + $$logmsg .= &mt('Incomplete course id defined.').$linefeed.&mt('Addition of user [_1] from domain [_2] to course [_3], section [_4] not completed.',$uname,$udom,$one.'_'.$two,$sec).$linefeed; $result = "error: incomplete course id\n"; } return $result; @@ -6634,6 +9161,45 @@ sub commit_studentrole { ############################################################ ############################################################ +sub check_clone { + my ($args,$linefeed) = @_; + my $cloneid='/'.$args->{'clonedomain'}.'/'.$args->{'clonecourse'}; + my ($clonecrsudom,$clonecrsunum)= &LONCAPA::split_courseid($cloneid); + my $clonehome=&Apache::lonnet::homeserver($clonecrsunum,$clonecrsudom); + my $clonemsg; + my $can_clone = 0; + + if ($clonehome eq 'no_host') { + $clonemsg = &mt('No new course created.').$linefeed.&mt('A new course could not be cloned from the specified original - [_1] - because it is a non-existent course.',$args->{'clonecourse'}.':'.$args->{'clonedomain'}); + } else { + my %clonedesc = &Apache::lonnet::coursedescription($cloneid,{'one_time' => 1}); + if ($env{'request.role.domain'} eq $args->{'clonedomain'}) { + $can_clone = 1; + } else { + my %clonehash = &Apache::lonnet::get('environment',['cloners'], + $args->{'clonedomain'},$args->{'clonecourse'}); + my @cloners = split(/,/,$clonehash{'cloners'}); + if (grep(/^\*$/,@cloners)) { + $can_clone = 1; + } elsif (grep(/^\*\:\Q$args->{'ccdomain'}\E$/,@cloners)) { + $can_clone = 1; + } else { + my %roleshash = + &Apache::lonnet::get_my_roles($args->{'ccuname'}, + $args->{'ccdomain'}, + 'userroles',['active'],['cc'], + [$args->{'clonedomain'}]); + if (($roleshash{$args->{'clonecourse'}.':'.$args->{'clonedomain'}.':cc'}) || (grep(/^\Q$args->{'ccuname'}\E:\Q$args->{'ccdomain'}\E$/,@cloners))) { + $can_clone = 1; + } else { + $clonemsg = &mt('No new course created.').$linefeed.&mt('The new course could not be cloned from the existing course because the new course owner ([_1]) does not have cloning rights in the existing course ([_2]).',$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'}); + } + } + } + } + return ($can_clone, $clonemsg, $cloneid, $clonehome); +} + sub construct_course { my ($args,$logmsg,$courseid,$crsudom,$crsunum,$udom,$uname,$context) = @_; my $outcome; @@ -6641,6 +9207,25 @@ sub construct_course { if ($context eq 'auto') { $linefeed = "\n"; } + +# +# Are we cloning? +# + my ($can_clone, $clonemsg, $cloneid, $clonehome); + if (($args->{'clonecourse'}) && ($args->{'clonedomain'})) { + ($can_clone, $clonemsg, $cloneid, $clonehome) = &check_clone($args,$linefeed); + if ($context ne 'auto') { + if ($clonemsg ne '') { + $clonemsg = ''.$clonemsg.''; + } + } + $outcome .= $clonemsg.$linefeed; + + if (!$can_clone) { + return (0,$outcome); + } + } + # # Open course # @@ -6661,81 +9246,48 @@ sub construct_course { # if anyone ever decides to not show this, and Utils::Course::new # will need to be suitably modified. $outcome .= &mt('New LON-CAPA [_1] ID: [_2]',$crstype,$$courseid).$linefeed; - # # Check if created correctly # ($$crsudom,$$crsunum)= &LONCAPA::split_courseid($$courseid); my $crsuhome=&Apache::lonnet::homeserver($$crsunum,$$crsudom); $outcome .= &mt('Created on').': '.$crsuhome.$linefeed; + # -# Are we cloning? -# - my $cloneid=''; - if (($args->{'clonecourse'}) && ($args->{'clonedomain'})) { - my $can_clone = 0; - $cloneid='/'.$args->{'clonedomain'}.'/'.$args->{'clonecourse'}; - my ($clonecrsudom,$clonecrsunum)= &LONCAPA::split_courseid($cloneid); - my $clonehome=&Apache::lonnet::homeserver($clonecrsunum,$clonecrsudom); - my $clonemsg; - if ($clonehome eq 'no_host') { - $clonemsg = &mt('Attempting to clone non-existing [_1]',$crstype); - if ($context eq 'auto') { - $outcome .= $clonemsg; - } else { - $outcome .= ''.$clonemsg.''; - } - $outcome .= $linefeed; - } else { - my %clonedesc = &Apache::lonnet::coursedescription($cloneid,{'one_time' => 1}); - if ($env{'request.role.domain'} eq $args->{'form.clonedomain'}) { - $can_clone = 1; - } else { - my %clonehash = &Apache::lonnet::get('environment',['cloners'], - $args->{'clonedomain'},$args->{'clonecourse'}); - my @cloners = split(/,/,$clonehash{'cloners'}); - my %roleshash = - &Apache::lonnet::get_my_roles($args->{'ccuname'}, - $args->{'ccdomain'},'userroles',['active'],['cc'], - [$args->{'clonedomain'}]); - if (($roleshash{$args->{'clonecourse'}.':'.$args->{'clonedomain'}.':cc'}) || (grep(/^\Q$args->{'ccuname'}\E:\Q$args->{'ccdomain'}\E$/,@cloners))) { - $can_clone = 1; - } else { - $clonemsg = &mt('The new course was not cloned from an existing course because the course owner ([_1]) does not have cloning rights in the existing course ([_2]).',$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'}); - if ($context eq 'auto') { - $outcome .= $clonemsg; - } else { - $outcome .= ''.$clonemsg.''; - } - $outcome .= $linefeed; - } - } - } - if ($can_clone) { - $clonemsg = &mt('Cloning [_1] from [_2]',$crstype,$clonehome); - if ($context eq 'auto') { - $outcome = $clonemsg; - } else { - $outcome .= ''.$clonemsg.''; - } - $outcome .= $linefeed; - my %oldcenv=&Apache::lonnet::dump('environment',$$crsudom,$$crsunum); +# Do the cloning +# + if ($can_clone && $cloneid) { + $clonemsg = &mt('Cloning [_1] from [_2]',$crstype,$clonehome); + if ($context ne 'auto') { + $clonemsg = ''.$clonemsg.''; + } + $outcome .= $clonemsg.$linefeed; + my %oldcenv=&Apache::lonnet::dump('environment',$$crsudom,$$crsunum); # Copy all files - &Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid); + &Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid,$args->{'datemode'},$args->{'dateshift'}); # Restore URL - $cenv{'url'}=$oldcenv{'url'}; + $cenv{'url'}=$oldcenv{'url'}; # Restore title - $cenv{'description'}=$oldcenv{'description'}; -# restore grading mode - if (defined($oldcenv{'grading'})) { - $cenv{'grading'}=$oldcenv{'grading'}; - } + $cenv{'description'}=$oldcenv{'description'}; # Mark as cloned - $cenv{'clonedfrom'}=$cloneid; - delete($cenv{'default_enrollment_start_date'}); - delete($cenv{'default_enrollment_end_date'}); - } + $cenv{'clonedfrom'}=$cloneid; +# Need to clone grading mode + my %newenv=&Apache::lonnet::get('environment',['grading'],$$crsudom,$$crsunum); + $cenv{'grading'}=$newenv{'grading'}; +# Do not clone these environment entries + &Apache::lonnet::del('environment', + ['default_enrollment_start_date', + 'default_enrollment_end_date', + 'question.email', + 'policy.email', + 'comment.email', + 'pch.users.denied', + 'plc.users.denied', + 'hidefromcat', + 'categories'], + $$crsudom,$$crsunum); } + # # Set environment (will override cloned, if existing) # @@ -6761,7 +9313,6 @@ sub construct_course { } else { $cenv{'internal.courseowner'} = $args->{'curruser'}; } - my @badclasses = (); # Used to accumulate sections/crosslistings that did not pass classlist access check for course owner. if ($args->{'crssections'}) { $cenv{'internal.sectionnums'} = ''; @@ -6821,7 +9372,7 @@ sub construct_course { } if ($args->{'notify_dc'}) { if ($uname ne '') { - push(@notified,$uname.'@'.$udom); + push(@notified,$uname.':'.$udom); } } if (@notified > 0) { @@ -6843,7 +9394,7 @@ sub construct_course { ' ('.$lt{'adby'}.')'; if ($context eq 'auto') { $outcome .= $badclass_msg.$linefeed; - $outcome .= ''.$badclass_msg.$linefeed.'
    '."\n"; + $outcome .= '
    '.$badclass_msg.$linefeed.'
      '."\n"; foreach my $item (@badclasses) { if ($context eq 'auto') { $outcome .= " - $item\n"; @@ -6854,7 +9405,7 @@ sub construct_course { if ($context eq 'auto') { $outcome .= $linefeed; } else { - $outcome .= "


    \n"; + $outcome .= "


\n"; } } } @@ -6876,7 +9427,7 @@ sub construct_course { if ($context eq 'auto') { $outcome .= $krb_msg; } else { - $outcome .= ''.$krb_msg.''; + $outcome .= ''.$krb_msg.''; } $outcome .= $linefeed; } @@ -6961,10 +9512,10 @@ sub construct_course { $outcome .= ($fatal?$errtext:'read ok').' - '; my $title; my $url; if ($args->{'firstres'} eq 'syl') { - $title='Syllabus'; + $title=&mt('Syllabus'); $url='/public/'.$$crsudom.'/'.$$crsunum.'/syllabus'; } else { - $title='Navigate Contents'; + $title=&mt('Navigate Contents'); $url='/adm/navmaps'; } @@ -6974,7 +9525,8 @@ sub construct_course { if ($errtext) { $fatal=2; } $outcome .= ($fatal?$errtext:'write ok').$linefeed; } - return $outcome; + + return (1,$outcome); } ############################################################ @@ -7018,10 +9570,13 @@ sub icon { } sub lonhttpdurl { +# +# Had been used for "small fry" static images on separate port 8080. +# Modify here if lightweight http functionality desired again. +# Currently eliminated due to increasing firewall issues. +# my ($url)=@_; - my $lonhttpd_port=$Apache::lonnet::perlvar{'lonhttpdPort'}; - if (!defined($lonhttpd_port)) { $lonhttpd_port='8080'; } - return 'http://'.$ENV{'SERVER_NAME'}.':'.$lonhttpd_port.$url; + return $url; } sub connection_aborted { @@ -7057,6 +9612,22 @@ sub escape_url { return join('/',@urlslices).'/'.$lastitem; } +sub compare_arrays { + my ($arrayref1,$arrayref2) = @_; + my (@difference,%count); + @difference = (); + %count = (); + if ((ref($arrayref1) eq 'ARRAY') && (ref($arrayref2) eq 'ARRAY')) { + foreach my $element (@{$arrayref1}, @{$arrayref2}) { $count{$element}++; } + foreach my $element (keys(%count)) { + if ($count{$element} == 1) { + push(@difference,$element); + } + } + } + return @difference; +} + # -------------------------------------------------------- Initliaze user login sub init_user_environment { my ($r, $username, $domain, $authhost, $form, $args) = @_; @@ -7099,7 +9670,7 @@ sub init_user_environment { } # Give them a new cookie my $id = ($args->{'robot'} ? 'robot'.$args->{'robot'} - : $now); + : $now.$$.int(rand(10000))); $cookie="$username\_$id\_$domain\_$authhost"; # Initialize roles @@ -7187,6 +9758,17 @@ sub init_user_environment { } } + foreach my $tool ('aboutme','blog','portfolio') { + $userenv{'availabletools.'.$tool} = + &Apache::lonnet::usertools_access($username,$domain,$tool,'reload'); + } + + foreach my $crstype ('official','unofficial') { + $userenv{'canrequest.'.$crstype} = + &Apache::lonnet::usertools_access($username,$domain,$crstype, + 'reload','requestcourses'); + } + $env{'user.environment'} = "$lonids/$cookie.id"; if (tie(my %disk_env,'GDBM_File',"$lonids/$cookie.id", @@ -7214,12 +9796,54 @@ sub init_user_environment { sub _add_to_env { my ($idf,$env_data,$prefix) = @_; - while (my ($key,$value) = each(%$env_data)) { - $idf->{$prefix.$key} = $value; - $env{$prefix.$key} = $value; + if (ref($env_data) eq 'HASH') { + while (my ($key,$value) = each(%$env_data)) { + $idf->{$prefix.$key} = $value; + $env{$prefix.$key} = $value; + } + } +} + +# --- Get the symbolic name of a problem and the url +sub get_symb { + my ($request,$silent) = @_; + (my $url=$env{'form.url'}) =~ s-^https?\://($ENV{'SERVER_NAME'}|$ENV{'HTTP_HOST'})--; + my $symb=($env{'form.symb'} ne '' ? $env{'form.symb'} : (&Apache::lonnet::symbread($url))); + if ($symb eq '') { + if (!$silent) { + $request->print("Unable to handle ambiguous references:$url:."); + return (); + } } + &Apache::lonenc::check_decrypt(\$symb); + return ($symb); } +# --------------------------------------------------------------Get annotation + +sub get_annotation { + my ($symb,$enc) = @_; + + my $key = $symb; + if (!$enc) { + $key = + &Apache::lonnet::clutter((&Apache::lonnet::decode_symb($symb))[2]); + } + my %annotation=&Apache::lonnet::get('nohist_annotations',[$key]); + return $annotation{$key}; +} + +sub clean_symb { + my ($symb,$delete_enc) = @_; + + &Apache::lonenc::check_decrypt(\$symb); + my $enc = $env{'request.enc'}; + if ($delete_enc) { + delete($env{'request.enc'}); + } + + return ($symb,$enc); +} =pod
'. - &mt('Field').''.&mt('Samples').'
'. + &mt('Field').''.&mt('Samples').'
'); - foreach my $line (0..2) { + foreach my $line (0..($max_samples-1)) { if (defined($samples->[$line]{$key})) { $r->print($samples->[$line]{$key}."
\n"); } } - $r->print('
'. + ''.$parent.''. + '
'; + for (my $j=0; $j<$numchildren; $j++) { + $name = $cats->[$depth]{$parent}[$j]; + $item = &escape($name).':'.&escape($parent).':'.$depth; + my $deeper = $depth+1; + my $checked = ''; + if (ref($currcategories) eq 'ARRAY') { + if (@{$currcategories} > 0) { + if (grep(/^\Q$item\E$/,@{$currcategories})) { + $checked = ' checked="checked" '; + } + } + } + $text .= ''; + } + $text .= '
'. + ''. + ''; + if (ref($path) eq 'ARRAY') { + push(@{$path},$name); + $text .= &assign_category_rows($itemcount,$cats,$deeper,$name,$path,$currcategories); + pop(@{$path}); + } + $text .= '