--- loncom/interface/loncommon.pm 2017/11/16 13:31:29 1.1302 +++ loncom/interface/loncommon.pm 2021/11/24 04:25:01 1.1371 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # a pile of common routines # -# $Id: loncommon.pm,v 1.1302 2017/11/16 13:31:29 raeburn Exp $ +# $Id: loncommon.pm,v 1.1371 2021/11/24 04:25:01 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -72,6 +72,7 @@ use Apache::lonuserstate(); use Apache::courseclassifier(); use LONCAPA qw(:DEFAULT :match); use LONCAPA::LWPReq; +use HTTP::Request; use DateTime::TimeZone; use DateTime::Locale; use Encode(); @@ -79,13 +80,14 @@ use Text::Aspell; use Authen::Captcha; use Captcha::reCAPTCHA; use JSON::DWIW; -use LWP::UserAgent; use Crypt::DES; use DynaLoader; # for Crypt::DES version use MIME::Lite; use MIME::Types; use File::Copy(); use File::Path(); +use String::CRC32(); +use Short::URL(); # ---------------------------------------------- Designs use vars qw(%defaultdesign); @@ -201,7 +203,7 @@ BEGIN { { my $langtabfile = $Apache::lonnet::perlvar{'lonTabDir'}. '/language.tab'; - if ( open(my $fh,"<$langtabfile") ) { + if ( open(my $fh,'<',$langtabfile) ) { while (my $line = <$fh>) { next if ($line=~/^\#/); chomp($line); @@ -223,7 +225,7 @@ BEGIN { { my $copyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}. '/copyright.tab'; - if ( open (my $fh,"<$copyrightfile") ) { + if ( open (my $fh,'<',$copyrightfile) ) { while (my $line = <$fh>) { next if ($line=~/^\#/); chomp($line); @@ -237,7 +239,7 @@ BEGIN { { my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}. '/source_copyright.tab'; - if ( open (my $fh,"<$sourcecopyrightfile") ) { + if ( open (my $fh,'<',$sourcecopyrightfile) ) { while (my $line = <$fh>) { next if ($line =~ /^\#/); chomp($line); @@ -251,7 +253,7 @@ BEGIN { # -------------------------------------------------------------- default domain designs my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors'; my $designfile = $designdir.'/default.tab'; - if ( open (my $fh,"<$designfile") ) { + if ( open (my $fh,'<',$designfile) ) { while (my $line = <$fh>) { next if ($line =~ /^\#/); chomp($line); @@ -265,7 +267,7 @@ BEGIN { { my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}. '/filecategories.tab'; - if ( open (my $fh,"<$categoryfile") ) { + if ( open (my $fh,'<',$categoryfile) ) { while (my $line = <$fh>) { next if ($line =~ /^\#/); chomp($line); @@ -280,7 +282,7 @@ BEGIN { { my $typesfile = $Apache::lonnet::perlvar{'lonTabDir'}. '/filetypes.tab'; - if ( open (my $fh,"<$typesfile") ) { + if ( open (my $fh,'<',$typesfile) ) { while (my $line = <$fh>) { next if ($line =~ /^\#/); chomp($line); @@ -433,7 +435,7 @@ sub studentbrowser_javascript { OFFLOAD - } } } } @@ -8590,6 +8977,9 @@ $args - additional optional args support will contain https:// if server uses https (as per hosts.tab), but request is for http hostname -> hostname, originally from $r->hostname(), (optional). + links_disabled -> Links in primary and secondary menus are disabled + (Can enable them once page has loaded - see lonroles.pm + for an example). =back @@ -8602,12 +8992,82 @@ sub start_page { #&Apache::lonnet::logthis("start_page ".join(':',caller(0))); $env{'internal.start_page'}++; - my ($result,@advtools); + my ($result,@advtools,$ltiscope,$ltiuri,%ltimenu,$menucoll,%menu); if (! exists($args->{'skip_phases'}{'head'}) ) { $result .= &xml_begin($args->{'frameset'}) . &headtag($title, $head_extra, $args); } - + + if (($env{'request.course.id'}) && ($env{'request.lti.login'})) { + if ($env{'course.'.$env{'request.course.id'}.'.lti.override'}) { + unless ($env{'course.'.$env{'request.course.id'}.'.lti.topmenu'}) { + $args->{'no_primary_menu'} = 1; + } + unless ($env{'course.'.$env{'request.course.id'}.'.lti.inlinemenu'}) { + $args->{'no_inline_menu'} = 1; + } + if ($env{'course.'.$env{'request.course.id'}.'.lti.lcmenu'}) { + map { $ltimenu{$_} = 1; } split(/,/,$env{'course.'.$env{'request.course.id'}.'.lti.lcmenu'}); + } + } else { + my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; + my %lti = &Apache::lonnet::get_domain_lti($cdom,'provider'); + if (ref($lti{$env{'request.lti.login'}}) eq 'HASH') { + unless ($lti{$env{'request.lti.login'}}{'topmenu'}) { + $args->{'no_primary_menu'} = 1; + } + unless ($lti{$env{'request.lti.login'}}{'inlinemenu'}) { + $args->{'no_inline_menu'} = 1; + } + if (ref($lti{$env{'request.lti.login'}}{'lcmenu'}) eq 'ARRAY') { + map { $ltimenu{$_} = 1; } @{$lti{$env{'request.lti.login'}}{'lcmenu'}}; + } + } + } + ($ltiscope,$ltiuri) = &LONCAPA::ltiutils::lti_provider_scope($env{'request.lti.uri'}, + $env{'course.'.$env{'request.course.id'}.'.domain'}, + $env{'course.'.$env{'request.course.id'}.'.num'}); + } elsif ($env{'request.course.id'}) { + my $expiretime=600; + if ((time-$env{'course.'.$env{'request.course.id'}.'.last_cache'}) > $expiretime) { + &Apache::lonnet::coursedescription($env{'request.course.id'},{'freshen_cache' => 1}); + } + my ($deeplinkmenu,$menuref); + ($menucoll,$deeplinkmenu,$menuref) = &menucoll_in_effect(); + if ($menucoll) { + if (ref($menuref) eq 'HASH') { + %menu = %{$menuref}; + } + if ($menu{'top'} eq 'n') { + $args->{'no_primary_menu'} = 1; + } + if ($menu{'inline'} eq 'n') { + unless (&Apache::lonnet::allowed('opa')) { + my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; + my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; + my $crstype = &course_type(); + my $now = time; + my $ccrole; + if ($crstype eq 'Community') { + $ccrole = 'co'; + } else { + $ccrole = 'cc'; + } + if ($env{'user.role.'.$ccrole.'./'.$cdom.'/'.$cnum}) { + my ($start,$end) = split(/\./,$env{'user.role.'.$ccrole.'./'.$cdom.'/'.$cnum}); + if ((($start) && ($start<0)) || + (($end) && ($end<$now)) || + (($start) && ($now<$start))) { + $args->{'no_inline_menu'} = 1; + } + } else { + $args->{'no_inline_menu'} = 1; + } + } + } + } + } + if (! exists($args->{'skip_phases'}{'body'}) ) { if ($args->{'frameset'}) { my $attr_string = &make_attr_string($args->{'force_register'}, @@ -8620,7 +9080,7 @@ sub start_page { $args->{'only_body'}, $args->{'domain'}, $args->{'force_register'}, $args->{'no_nav_bar'}, $args->{'bgcolor'}, $args, - \@advtools); + \@advtools,$ltiscope,$ltiuri,\%ltimenu,$menucoll,\%menu); } } @@ -8656,6 +9116,7 @@ sub start_page { my $menulink; # if arg: bread_crumbs_nomenu is true pass 0 as $menulink item. if ((exists($args->{'bread_crumbs_nomenu'})) || + ($ltiscope eq 'map') || ($ltiscope eq 'resource') || ((($args->{'crstype'} eq 'Placement') || (($env{'request.course.id'}) && ($env{'course.'.$env{'request.course.id'}.'.type'} eq 'Placement'))) && (!$env{'request.role.adv'}))) { @@ -8705,6 +9166,103 @@ sub end_page { return $result; } +sub menucoll_in_effect { + my ($menucoll,$deeplinkmenu,%menu); + if ($env{'request.course.id'}) { + $menucoll = $env{'course.'.$env{'request.course.id'}.'.menudefault'}; + if ($env{'request.deeplink.login'}) { + my ($deeplink_symb,$deeplink,$check_login_symb); + my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; + my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; + if ($env{'request.noversionuri'} =~ m{^/(res|uploaded)/}) { + if ($env{'request.noversionuri'} =~ /\.(page|sequence)$/) { + my $navmap = Apache::lonnavmaps::navmap->new(); + if (ref($navmap)) { + $deeplink = $navmap->get_mapparam(undef, + &Apache::lonnet::declutter($env{'request.noversionuri'}), + '0.deeplink'); + } else { + $check_login_symb = 1; + } + } else { + my $symb = &Apache::lonnet::symbread(); + if ($symb) { + $deeplink = &Apache::lonnet::EXT('resource.0.deeplink',$symb); + } else { + $check_login_symb = 1; + } + } + } else { + $check_login_symb = 1; + } + if ($check_login_symb) { + $deeplink_symb = &deeplink_login_symb($cnum,$cdom); + if ($deeplink_symb =~ /\.(page|sequence)$/) { + my $mapname = &Apache::lonnet::deversion((&Apache::lonnet::decode_symb($deeplink_symb))[2]); + my $navmap = Apache::lonnavmaps::navmap->new(); + if (ref($navmap)) { + $deeplink = $navmap->get_mapparam(undef,$mapname,'0.deeplink'); + } + } else { + $deeplink = &Apache::lonnet::EXT('resource.0.deeplink',$deeplink_symb); + } + } + if ($deeplink ne '') { + my ($state,$others,$listed,$scope,$protect,$display) = split(/,/,$deeplink); + if ($display =~ /^\d+$/) { + $deeplinkmenu = 1; + $menucoll = $display; + } + } + } + if ($menucoll) { + %menu = &page_menu($env{'course.'.$env{'request.course.id'}.'.menucollections'},$menucoll); + } + } + return ($menucoll,$deeplinkmenu,\%menu); +} + +sub deeplink_login_symb { + my ($cnum,$cdom) = @_; + my $login_symb; + if ($env{'request.deeplink.login'}) { + $login_symb = &symb_from_tinyurl($env{'request.deeplink.login'},$cnum,$cdom); + } + return $login_symb; +} + +sub symb_from_tinyurl { + my ($url,$cnum,$cdom) = @_; + if ($url =~ m{^\Q/tiny/$cdom/\E(\w+)$}) { + my $key = $1; + my ($tinyurl,$login); + my ($result,$cached)=&Apache::lonnet::is_cached_new('tiny',$cdom."\0".$key); + if (defined($cached)) { + $tinyurl = $result; + } else { + my $configuname = &Apache::lonnet::get_domainconfiguser($cdom); + my %currtiny = &Apache::lonnet::get('tiny',[$key],$cdom,$configuname); + if ($currtiny{$key} ne '') { + $tinyurl = $currtiny{$key}; + &Apache::lonnet::do_cache_new('tiny',$cdom."\0".$key,$currtiny{$key},600); + } + } + if ($tinyurl ne '') { + my ($cnumreq,$symb) = split(/\&/,$tinyurl); + if (wantarray) { + return ($cnumreq,$symb); + } elsif ($cnumreq eq $cnum) { + return $symb; + } + } + } + if (wantarray) { + return (); + } else { + return; + } +} + sub wishlist_window { return(<<'ENDWISHLIST'); @@ -8813,7 +9379,7 @@ ENDADHOC } sub modal_adhoc_inner { - my ($funcname,$width,$height,$content)=@_; + my ($funcname,$width,$height,$content,$possmathjax)=@_; my $innerwidth=$width-20; $content=&js_ready( &start_page('Dialog',undef,{'only_body'=>1,'bgcolor'=>'#FFFFFF'}). @@ -8822,12 +9388,12 @@ sub modal_adhoc_inner { &end_scrollbox(). &end_page() ); - return &modal_adhoc_script($funcname,$width,$height,$content); + return &modal_adhoc_script($funcname,$width,$height,$content,$possmathjax); } sub modal_adhoc_window { - my ($funcname,$width,$height,$content,$linktext)=@_; - return &modal_adhoc_inner($funcname,$width,$height,$content). + my ($funcname,$width,$height,$content,$linktext,$possmathjax)=@_; + return &modal_adhoc_inner($funcname,$width,$height,$content,$possmathjax). "".$linktext.""; } @@ -9188,14 +9754,21 @@ function expand_div(caller) { sub simple_error_page { my ($r,$title,$msg,$args) = @_; + my %displayargs; if (ref($args) eq 'HASH') { if (!$args->{'no_auto_mt_msg'}) { $msg = &mt($msg); } + if ($args->{'only_body'}) { + $displayargs{'only_body'} = 1; + } + if ($args->{'no_nav_bar'}) { + $displayargs{'no_nav_bar'} = 1; + } } else { $msg = &mt($msg); } my $page = - &Apache::loncommon::start_page($title). + &Apache::loncommon::start_page($title,'',\%displayargs). '

'.$msg.'

'. &Apache::loncommon::end_page(); if (ref($r)) { @@ -10695,11 +11268,15 @@ sub sorted_inst_types { } sub get_institutional_codes { - my ($settings,$allcourses,$LC_code) = @_; + my ($cdom,$crs,$settings,$allcourses,$LC_code) = @_; # Get complete list of course sections to update my @currsections = (); my @currxlists = (); + my (%unclutteredsec,%unclutteredlcsec); my $coursecode = $$settings{'internal.coursecode'}; + my $crskey = $crs.':'.$coursecode; + @{$unclutteredsec{$crskey}} = (); + @{$unclutteredlcsec{$crskey}} = (); if ($$settings{'internal.sectionnums'} ne '') { @currsections = split(/,/,$$settings{'internal.sectionnums'}); @@ -10710,8 +11287,8 @@ sub get_institutional_codes { } if (@currxlists > 0) { - foreach (@currxlists) { - if (m/^([^:]+):(\w*)$/) { + foreach my $xl (@currxlists) { + if ($xl =~ /^([^:]+):(\w*)$/) { unless (grep/^$1$/,@{$allcourses}) { push(@{$allcourses},$1); $$LC_code{$1} = $2; @@ -10719,15 +11296,28 @@ sub get_institutional_codes { } } } - + if (@currsections > 0) { - foreach (@currsections) { - if (m/^(\w+):(\w*)$/) { - my $sec = $coursecode.$1; + foreach my $sec (@currsections) { + if ($sec =~ m/^(\w+):(\w*)$/ ) { + my $instsec = $1; my $lc_sec = $2; - unless (grep/^$sec$/,@{$allcourses}) { + unless (grep/^\Q$instsec\E$/,@{$unclutteredsec{$crskey}}) { + push(@{$unclutteredsec{$crskey}},$instsec); + push(@{$unclutteredlcsec{$crskey}},$lc_sec); + } + } + } + } + + if (@{$unclutteredsec{$crskey}} > 0) { + my %formattedsec = &Apache::lonnet::auto_instsec_reformat($cdom,'clutter',\%unclutteredsec); + if ((ref($formattedsec{$crskey}) eq 'ARRAY') && (ref($unclutteredlcsec{$crskey}) eq 'ARRAY')) { + for (my $i=0; $i<@{$formattedsec{$crskey}}; $i++) { + my $sec = $coursecode.$formattedsec{$crskey}[$i]; + unless (grep/^\Q$sec\E$/,@{$allcourses}) { push(@{$allcourses},$sec); - $$LC_code{$sec} = $lc_sec; + $$LC_code{$sec} = $unclutteredlcsec{$crskey}[$i]; } } } @@ -12054,7 +12644,7 @@ sub modify_html_refs { return; } } - if (open(my $fh,"<$container")) { + if (open(my $fh,'<',$container)) { $content = join('', <$fh>); close($fh); } else { @@ -12119,7 +12709,7 @@ sub modify_html_refs { } } } else { - if (open(my $fh,">$container")) { + if (open(my $fh,'>',$container)) { print $fh $content; close($fh); $output = '

'.&mt('Updated [quant,_1,reference] in [_2].', @@ -13748,7 +14338,7 @@ sub upfile_store { { my $datafile = $r->dir_config('lonDaemons'). '/tmp/'.$datatoken.'.tmp'; - if ( open(my $fh,">$datafile") ) { + if ( open(my $fh,'>',$datafile) ) { print $fh $env{'form.upfile'}; close($fh); } @@ -13773,7 +14363,7 @@ sub load_tmp_file { { my $studentfile = $r->dir_config('lonDaemons'). '/tmp/'.$datatoken.'.tmp'; - if ( open(my $fh,"<$studentfile") ) { + if ( open(my $fh,'<',$studentfile) ) { @studentdata=<$fh>; close($fh); } @@ -13783,7 +14373,7 @@ sub load_tmp_file { sub valid_datatoken { my ($datatoken) = @_; - if ($datatoken =~ /^$match_username\_$match_domain\_enroll_$match_domain\_$match_courseid\_\d+_\d+$/) { + if ($datatoken =~ /^$match_username\_$match_domain\_enroll_(|$match_domain\_$match_courseid)\_\d+_\d+$/) { return $datatoken; } return; @@ -14939,6 +15529,8 @@ Inputs: from - Sender's email address +replyto - Reply-To email address + to - Email address of recipient subject - Subject of email @@ -14949,8 +15541,6 @@ cc_string - Carbon copy email ad bcc - Blind carbon copy email address -type - File type of attachment - attachment_path - Path of file to be attached file_name - Name of file to be attached @@ -14967,8 +15557,9 @@ attachment_text - The body of an attac ############################################################ sub mime_email { - my ($from, $to, $subject, $body, $cc_string, $bcc, $attachment_path, - $file_name, $attachment_text) = @_; + my ($from,$replyto,$to,$subject,$body,$cc_string,$bcc,$attachment_path, + $file_name,$attachment_text) = @_; + my $msg = MIME::Lite->new( From => $from, To => $to, @@ -14976,6 +15567,9 @@ sub mime_email { Type =>'TEXT', Data => $body, ); + if ($replyto ne '') { + $msg->add("Reply-To" => $replyto); + } if ($cc_string ne '') { $msg->add("Cc" => $cc_string); } @@ -15091,6 +15685,8 @@ jsarray (reference to array of categorie subcats (reference to hash of arrays containing all subcategories within each category, -recursive) +maxd (reference to hash used to hold max depth for all top-level categories). + Returns: nothing Side effects: populates trails and allitems hash references. @@ -15098,7 +15694,7 @@ Side effects: populates trails and allit =cut sub extract_categories { - my ($categories,$cats,$trails,$allitems,$idx,$jsarray,$subcats) = @_; + my ($categories,$cats,$trails,$allitems,$idx,$jsarray,$subcats,$maxd) = @_; if (ref($categories) eq 'HASH') { &gather_categories($categories,$cats,$idx,$jsarray); if (ref($cats->[0]) eq 'ARRAY') { @@ -15126,12 +15722,15 @@ sub extract_categories { if (ref($subcats) eq 'HASH') { push(@{$subcats->{$item}},&escape($category).':'.&escape($name).':1'); } - &recurse_categories($cats,2,$category,$trails,$allitems,\@parents,$subcats); + &recurse_categories($cats,2,$category,$trails,$allitems,\@parents,$subcats,$maxd); } } else { if (ref($subcats) eq 'HASH') { $subcats->{$item} = []; } + if (ref($maxd) eq 'HASH') { + $maxd->{$name} = 1; + } } } } @@ -15169,13 +15768,13 @@ Side effects: populates trails and allit =cut sub recurse_categories { - my ($cats,$depth,$category,$trails,$allitems,$parents,$subcats) = @_; + my ($cats,$depth,$category,$trails,$allitems,$parents,$subcats,$maxd) = @_; 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)); + my $trailstr = join(' » ',(@{$parents},$category)); if ($allitems->{$item} eq '') { push(@{$trails},$trailstr); $allitems->{$item} = scalar(@{$trails})-1; @@ -15196,16 +15795,21 @@ sub recurse_categories { } } &recurse_categories($cats,$deeper,$name,$trails,$allitems,$parents, - $subcats); + $subcats,$maxd); pop(@{$parents}); } } else { my $item = &escape($category).':'.&escape($parents->[-1]).':'.$shallower; - my $trailstr = join(' -> ',(@{$parents},$category)); + my $trailstr = join(' » ',(@{$parents},$category)); if ($allitems->{$item} eq '') { push(@{$trails},$trailstr); $allitems->{$item} = scalar(@{$trails})-1; } + if (ref($maxd) eq 'HASH') { + if ($depth > $maxd->{$parents->[0]}) { + $maxd->{$parents->[0]} = $depth; + } + } } return; } @@ -15237,8 +15841,8 @@ sub assign_categories_table { my ($cathash,$currcat,$type,$disabled) = @_; my $output; if (ref($cathash) eq 'HASH') { - my (@cats,@trails,%allitems,%idx,@jsarray,@path,$maxdepth); - &extract_categories($cathash,\@cats,\@trails,\%allitems,\%idx,\@jsarray); + my (@cats,@trails,%allitems,%idx,@jsarray,%maxd,@path,$maxdepth); + &extract_categories($cathash,\@cats,\@trails,\%allitems,\%idx,\@jsarray,\%maxd); $maxdepth = scalar(@cats); if (@cats > 0) { my $itemcount = 0; @@ -15564,7 +16168,8 @@ sub check_clone { my $cloneid='/'.$args->{'clonedomain'}.'/'.$args->{'clonecourse'}; my ($clonecrsudom,$clonecrsunum)= &LONCAPA::split_courseid($cloneid); my $clonehome=&Apache::lonnet::homeserver($clonecrsunum,$clonecrsudom); - my $clonemsg; + my $clonetitle; + my @clonemsg; my $can_clone = 0; my $lctype = lc($args->{'crstype'}); if ($lctype ne 'community') { @@ -15572,16 +16177,38 @@ sub check_clone { } if ($clonehome eq 'no_host') { if ($args->{'crstype'} eq 'Community') { - $clonemsg = &mt('No new community created.').$linefeed.&mt('A new community could not be cloned from the specified original - [_1] - because it is a non-existent community.',$args->{'clonecourse'}.':'.$args->{'clonedomain'}); + push(@clonemsg,({ + mt => 'No new community created.', + args => [], + }, + { + mt => 'A new community could not be cloned from the specified original - [_1] - because it is a non-existent community.', + args => [$args->{'clonedomain'}.':'.$args->{'clonedomain'}], + })); } else { - $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'}); - } + push(@clonemsg,({ + mt => 'No new course created.', + args => [], + }, + { + mt => 'A new course could not be cloned from the specified original - [_1] - because it is a non-existent course.', + args => [$args->{'clonecourse'}.':'.$args->{'clonedomain'}], + })); + } } else { my %clonedesc = &Apache::lonnet::coursedescription($cloneid,{'one_time' => 1}); + $clonetitle = $clonedesc{'description'}; if ($args->{'crstype'} eq 'Community') { if ($clonedesc{'type'} ne 'Community') { - $clonemsg = &mt('No new community created.').$linefeed.&mt('A new community could not be cloned from the specified original - [_1] - because it is a course not a community.',$args->{'clonecourse'}.':'.$args->{'clonedomain'}); - return ($can_clone, $clonemsg, $cloneid, $clonehome); + push(@clonemsg,({ + mt => 'No new community created.', + args => [], + }, + { + mt => 'A new community could not be cloned from the specified original - [_1] - because it is a course not a community.', + args => [$args->{'clonecourse'}.':'.$args->{'clonedomain'}], + })); + return ($can_clone,\@clonemsg,$cloneid,$clonehome); } } if (($env{'request.role.domain'} eq $args->{'clonedomain'}) && @@ -15670,20 +16297,34 @@ sub check_clone { } unless ($can_clone) { if ($args->{'crstype'} eq 'Community') { - $clonemsg = &mt('No new community created.').$linefeed.&mt('The new community could not be cloned from the existing community because the new community owner ([_1]) does not have cloning rights in the existing community ([_2]).',$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'}); + push(@clonemsg,({ + mt => 'No new community created.', + args => [], + }, + { + mt => 'The new community could not be cloned from the existing community because the new community owner ([_1]) does not have cloning rights in the existing community ([_2]).', + args => [$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'}], + })); } 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'}); + push(@clonemsg,({ + mt => 'No new course created.', + args => [], + }, + { + 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 => [$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'}], + })); } } } } - return ($can_clone, $clonemsg, $cloneid, $clonehome); + return ($can_clone,\@clonemsg,$cloneid,$clonehome,$clonetitle); } sub construct_course { my ($args,$logmsg,$courseid,$crsudom,$crsunum,$udom,$uname,$context, - $cnum,$category,$coderef) = @_; - my $outcome; + $cnum,$category,$coderef,$callercontext,$user_lh) = @_; + my ($outcome,$msgref,$clonemsgref); my $linefeed = '
'."\n"; if ($context eq 'auto') { $linefeed = "\n"; @@ -15692,18 +16333,11 @@ sub construct_course { # # Are we cloning? # - my ($can_clone, $clonemsg, $cloneid, $clonehome); + my ($can_clone,$cloneid,$clonehome,$clonetitle); 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; - + ($can_clone,$clonemsgref,$cloneid,$clonehome,$clonetitle) = &check_clone($args,$linefeed); if (!$can_clone) { - return (0,$outcome); + return (0,$outcome,$clonemsgref); } } @@ -15726,15 +16360,20 @@ sub construct_course { $args->{'ccuname'}.':'. $args->{'ccdomain'}, $args->{'crstype'}, - $cnum,$context,$category); + $cnum,$context,$category, + $callercontext); # Note: The testing routines depend on this being output; see # Utils::Course. This needs to at least be output as a comment # 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]',$showncrstype,$$courseid).$linefeed; + if (($callercontext eq 'auto') && ($user_lh ne '')) { + $outcome .= &mt_user($user_lh,'New LON-CAPA [_1] ID: [_2]',$showncrstype,$$courseid).$linefeed; + } else { + $outcome .= &mt('New LON-CAPA [_1] ID: [_2]',$showncrstype,$$courseid).$linefeed; + } if ($$courseid =~ /^error:/) { - return (0,$outcome); + return (0,$outcome,$clonemsgref); } # @@ -15743,23 +16382,37 @@ sub construct_course { ($$crsudom,$$crsunum)= &LONCAPA::split_courseid($$courseid); my $crsuhome=&Apache::lonnet::homeserver($$crsunum,$$crsudom); if ($crsuhome eq 'no_host') { - $outcome .= &mt('Course creation failed, unrecognized course home server.').$linefeed; - return (0,$outcome); + if (($callercontext eq 'auto') && ($user_lh ne '')) { + $outcome .= &mt_user($user_lh, + 'Course creation failed, unrecognized course home server.'); + } else { + $outcome .= &mt('Course creation failed, unrecognized course home server.'); + } + $outcome .= $linefeed; + return (0,$outcome,$clonemsgref); } $outcome .= &mt('Created on').': '.$crsuhome.$linefeed; # # Do the cloning # + my @clonemsg; if ($can_clone && $cloneid) { - $clonemsg = &mt('Cloning [_1] from [_2]',$showncrstype,$clonehome); - if ($context ne 'auto') { - $clonemsg = ''.$clonemsg.''; - } - $outcome .= $clonemsg.$linefeed; + push(@clonemsg, + { + mt => 'Created [_1] by cloning from [_2]', + args => [$showncrstype,$clonetitle], + }); my %oldcenv=&Apache::lonnet::dump('environment',$$crsudom,$$crsunum); # Copy all files - &Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid,$args->{'datemode'},$args->{'dateshift'}); + my @info = + &Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid,$args->{'datemode'}, + $args->{'dateshift'},$args->{'crscode'}, + $args->{'ccuname'}.':'.$args->{'ccdomain'}, + $args->{'tinyurls'}); + if (@info) { + push(@clonemsg,@info); + } # Restore URL $cenv{'url'}=$oldcenv{'url'}; # Restore title @@ -15784,8 +16437,7 @@ sub construct_course { 'plc.users.denied', 'hidefromcat', 'checkforpriv', - 'categories', - 'internal.uniquecode'], + 'categories'], $$crsudom,$$crsunum); if ($args->{'textbook'}) { $cenv{'internal.textbook'} = $args->{'textbook'}; @@ -15800,6 +16452,9 @@ sub construct_course { if ($args->{'crstype'}) { $cenv{'type'}=$args->{'crstype'}; } + if ($args->{'lti'}) { + $cenv{'internal.lti'}=$args->{'lti'}; + } if ($args->{'crsid'}) { $cenv{'courseid'}=$args->{'crsid'}; } @@ -16026,12 +16681,17 @@ sub construct_course { # Open all assignments # if ($args->{'openall'}) { + my $opendate = time; + if ($args->{'openallfrom'} =~ /^\d+$/) { + $opendate = $args->{'openallfrom'}; + } my $storeunder=$$crsudom.'_'.$$crsunum.'.0.opendate'; - my %storecontent = ($storeunder => time, + my %storecontent = ($storeunder => $opendate, $storeunder.'.type' => 'date_start'); - - $outcome .= &mt('Opening all assignments').': '.&Apache::lonnet::cput - ('resourcedata',\%storecontent,$$crsudom,$$crsunum).$linefeed; + $outcome .= &mt('All assignments open starting [_1]', + &Apache::lonlocal::locallocaltime($opendate)).': '. + &Apache::lonnet::cput + ('resourcedata',\%storecontent,$$crsudom,$$crsunum).$linefeed; } # # Set first page @@ -16085,7 +16745,7 @@ sub construct_course { ('resourcedata',\%storecontent,$$crsudom,$$crsunum); } - return (1,$outcome); + return (1,$outcome,\@clonemsg); } sub make_unique_code { @@ -16169,13 +16829,14 @@ sub group_term { } sub course_types { - my @types = ('official','unofficial','community','textbook','placement'); + my @types = ('official','unofficial','community','textbook','placement','lti'); my %typename = ( official => 'Official course', unofficial => 'Unofficial course', community => 'Community', textbook => 'Textbook course', placement => 'Placement test', + lti => 'LTI provider', ); return (\@types,\%typename); } @@ -16255,6 +16916,24 @@ sub compare_arrays { return @difference; } +sub lon_status_items { + my %defaults = ( + E => 100, + W => 4, + N => 1, + U => 5, + threshold => 200, + sysmail => 2500, + ); + my %names = ( + E => 'Errors', + W => 'Warnings', + N => 'Notices', + U => 'Unsent', + ); + return (\%defaults,\%names); +} + # -------------------------------------------------------- Initialize user login sub init_user_environment { my ($r, $username, $domain, $authhost, $form, $args) = @_; @@ -16289,18 +16968,18 @@ sub init_user_environment { opendir(DIR,$lonids); while ($filename=readdir(DIR)) { if ($filename=~/^$username\_\d+\_$domain\_$authhost\.id$/) { - if ($ENV{'SERVER_PORT'} == 443) { + if (tie(my %oldenv,'GDBM_File',"$lonids/$filename", + &GDBM_READER(),0640)) { my $linkedfile; - if (tie(my %oldenv,'GDBM_File',"$lonids/$cookie.id", - &GDBM_READER(),0640)) { - if (exists($oldenv{'user.linkedenv'})) { - $linkedfile = $oldenv{'user.linkedenv'}; - } - untie(%oldenv); + if (exists($oldenv{'user.linkedenv'})) { + $linkedfile = $oldenv{'user.linkedenv'}; } - if (unlink($lonids.'/'.$filename)) { - if ($linkedfile =~ /^[a-f0-9]+_linked\.id$/) { - unlink($lonids.'/'.$linkedfile); + untie(%oldenv); + if (unlink("$lonids/$filename")) { + if ($linkedfile =~ /^[a-f0-9]+_linked$/) { + if (-l "$lonids/$linkedfile.id") { + unlink("$lonids/$linkedfile.id"); + } } } } else { @@ -16355,6 +17034,7 @@ sub init_user_environment { # --------------------------------------------------------- Write first profile { + my $ip = &Apache::lonnet::get_requestor_ip($r); my %initial_env = ("user.name" => $username, "user.domain" => $domain, @@ -16373,7 +17053,7 @@ sub init_user_environment { "request.course.sec" => '', "request.role" => 'cm', "request.role.adv" => $env{'user.adv'}, - "request.host" => $ENV{'REMOTE_ADDR'},); + "request.host" => $ip,); if ($form->{'localpath'}) { $initial_env{"browser.localpath"} = $form->{'localpath'}; @@ -16411,7 +17091,7 @@ sub init_user_environment { undef,\%userenv,\%domdef,\%is_adv); } - foreach my $crstype ('official','unofficial','community','textbook','placement') { + foreach my $crstype ('official','unofficial','community','textbook','placement','lti') { $userenv{'canrequest.'.$crstype} = &Apache::lonnet::usertools_access($username,$domain,$crstype, 'reload','requestcourses', @@ -17301,22 +17981,34 @@ sub needs_coursereinit { } sub update_content_constraints { - my ($cdom,$cnum,$chome,$cid) = @_; + my ($cdom,$cnum,$chome,$cid,$keeporder) = @_; my %curr_reqd_hash = &Apache::lonnet::userenvironment($cdom,$cnum,'internal.releaserequired'); my ($reqdmajor,$reqdminor) = split(/\./,$curr_reqd_hash{'internal.releaserequired'}); - my %checkresponsetypes; + my (%checkresponsetypes,%checkcrsrestypes); foreach my $key (keys(%Apache::lonnet::needsrelease)) { my ($item,$name,$value) = split(/:/,$key); if ($item eq 'resourcetag') { if ($name eq 'responsetype') { $checkresponsetypes{$value} = $Apache::lonnet::needsrelease{$key} } + } elsif ($item eq 'course') { + if ($name eq 'courserestype') { + $checkcrsrestypes{$value} = $Apache::lonnet::needsrelease{$key}; + } } } my $navmap = Apache::lonnavmaps::navmap->new(); if (defined($navmap)) { - my %allresponses; - foreach my $res ($navmap->retrieveResources(undef,sub { $_[0]->is_problem() },1,0)) { + my (%allresponses,%allcrsrestypes); + foreach my $res ($navmap->retrieveResources(undef,sub { $_[0]->is_problem() || $_[0]->is_tool() },1,0)) { + if ($res->is_tool()) { + if ($allcrsrestypes{'exttool'}) { + $allcrsrestypes{'exttool'} ++; + } else { + $allcrsrestypes{'exttool'} = 1; + } + next; + } my %responses = $res->responseTypes(); foreach my $key (keys(%responses)) { next unless(exists($checkresponsetypes{$key})); @@ -17329,8 +18021,38 @@ sub update_content_constraints { ($reqdmajor,$reqdminor) = ($major,$minor); } } + foreach my $key (keys(%allcrsrestypes)) { + my ($major,$minor) = split(/\./,$checkcrsrestypes{$key}); + if (($major > $reqdmajor) || ($major == $reqdmajor && $minor > $reqdminor)) { + ($reqdmajor,$reqdminor) = ($major,$minor); + } + } undef($navmap); } + my (@resources,@order,@resparms,@zombies); + if ($keeporder) { + use LONCAPA::map; + @resources = @LONCAPA::map::resources; + @order = @LONCAPA::map::order; + @resparms = @LONCAPA::map::resparms; + @zombies = @LONCAPA::map::zombies; + } + my $suppmap = 'supplemental.sequence'; + my ($suppcount,$supptools,$errors) = (0,0,0); + ($suppcount,$supptools,$errors) = &recurse_supplemental($cnum,$cdom,$suppmap, + $suppcount,$supptools,$errors); + if ($keeporder) { + @LONCAPA::map::resources = @resources; + @LONCAPA::map::order = @order; + @LONCAPA::map::resparms = @resparms; + @LONCAPA::map::zombies = @zombies; + } + if ($supptools) { + my ($major,$minor) = split(/\./,$checkcrsrestypes{'exttool'}); + if (($major > $reqdmajor) || ($major == $reqdmajor && $minor > $reqdminor)) { + ($reqdmajor,$reqdminor) = ($major,$minor); + } + } unless (($reqdmajor eq '') && ($reqdminor eq '')) { &Apache::lonnet::update_released_required($reqdmajor.'.'.$reqdminor,$cdom,$cnum,$chome,$cid); } @@ -17351,7 +18073,7 @@ sub allmaps_incourse { if ($lastchange > $env{'request.course.tied'}) { my ($furl,$ferr) = &Apache::lonuserstate::readmap("$cdom/$cnum"); unless ($ferr) { - &update_content_constraints($cdom,$cnum,$chome,$cid); + &update_content_constraints($cdom,$cnum,$chome,$cid,1); } } my $navmap = Apache::lonnavmaps::navmap->new(); @@ -17387,7 +18109,7 @@ sub parse_supplemental_title { } sub recurse_supplemental { - my ($cnum,$cdom,$suppmap,$numfiles,$errors) = @_; + my ($cnum,$cdom,$suppmap,$numfiles,$numexttools,$errors) = @_; if ($suppmap) { my ($errtext,$fatal) = &LONCAPA::map::mapread('/uploaded/'.$cdom.'/'.$cnum.'/'.$suppmap); if ($fatal) { @@ -17398,8 +18120,12 @@ sub recurse_supplemental { my ($title,$src,$ext,$type,$status)=split(/\:/,$res); if (($src ne '') && ($status eq 'res')) { if ($src =~ m{^\Q/uploaded/$cdom/$cnum/\E(supplemental_\d+\.sequence)$}) { - ($numfiles,$errors) = &recurse_supplemental($cnum,$cdom,$1,$numfiles,$errors); + ($numfiles,$numexttools,$errors) = &recurse_supplemental($cnum,$cdom,$1, + $numfiles,$numexttools,$errors); } else { + if ($src =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) { + $numexttools ++; + } $numfiles ++; } } @@ -17407,7 +18133,7 @@ sub recurse_supplemental { } } } - return ($numfiles,$errors); + return ($numfiles,$numexttools,$errors); } sub symb_to_docspath { @@ -17481,10 +18207,10 @@ sub symb_to_docspath { } sub captcha_display { - my ($context,$lonhost) = @_; + my ($context,$lonhost,$defdom) = @_; my ($output,$error); my ($captcha,$pubkey,$privkey,$version) = - &get_captcha_config($context,$lonhost); + &get_captcha_config($context,$lonhost,$defdom); if ($captcha eq 'original') { $output = &create_captcha(); unless ($output) { @@ -17500,9 +18226,9 @@ sub captcha_display { } sub captcha_response { - my ($context,$lonhost) = @_; + my ($context,$lonhost,$defdom) = @_; my ($captcha_chk,$captcha_error); - my ($captcha,$pubkey,$privkey,$version) = &get_captcha_config($context,$lonhost); + my ($captcha,$pubkey,$privkey,$version) = &get_captcha_config($context,$lonhost,$defdom); if ($captcha eq 'original') { ($captcha_chk,$captcha_error) = &check_captcha(); } elsif ($captcha eq 'recaptcha') { @@ -17514,7 +18240,7 @@ sub captcha_response { } sub get_captcha_config { - my ($context,$lonhost) = @_; + my ($context,$lonhost,$dom_in_effect) = @_; my ($captcha,$pubkey,$privkey,$version,$hashtocheck); my $hostname = &Apache::lonnet::hostname($lonhost); my $serverhomeID = &Apache::lonnet::get_server_homeID($hostname); @@ -17562,7 +18288,28 @@ sub get_captcha_config { } elsif ($domconfhash{$serverhomedom.'.login.captcha'} eq 'original') { $captcha = 'original'; } - } + } elsif ($context eq 'passwords') { + if ($dom_in_effect) { + my %passwdconf = &Apache::lonnet::get_passwdconf($dom_in_effect); + if ($passwdconf{'captcha'} eq 'recaptcha') { + if (ref($passwdconf{'recaptchakeys'}) eq 'HASH') { + $pubkey = $passwdconf{'recaptchakeys'}{'public'}; + $privkey = $passwdconf{'recaptchakeys'}{'private'}; + } + if ($privkey && $pubkey) { + $captcha = 'recaptcha'; + $version = $passwdconf{'recaptchaversion'}; + if ($version ne '2') { + $version = 1; + } + } else { + $captcha = 'original'; + } + } elsif ($passwdconf{'captcha'} ne 'notused') { + $captcha = 'original'; + } + } + } return ($captcha,$pubkey,$privkey,$version); } @@ -17579,13 +18326,17 @@ sub create_captcha { if (-e $Apache::lonnet::perlvar{'lonCaptchaDir'}.'/'.$md5sum.'.png') { $output = ''."\n". + ''. &mt('Type in the letters/numbers shown below').' '. ''. - '
'. + '
'. 'captcha'; last; } } + if ($output eq '') { + &Apache::lonnet::logthis("Failed to create Captcha code after $tries attempts."); + } return $output; } @@ -17624,7 +18375,8 @@ sub check_captcha { sub create_recaptcha { my ($pubkey,$version) = @_; if ($version >= 2) { - return '

'; + return '
'. + '
'; } else { my $use_ssl; if ($ENV{'SERVER_PORT'} == 443) { @@ -17642,11 +18394,12 @@ sub create_recaptcha { sub check_recaptcha { my ($privkey,$version) = @_; my $captcha_chk; + my $ip = &Apache::lonnet::get_requestor_ip(); if ($version >= 2) { my %info = ( secret => $privkey, response => $env{'form.g-recaptcha-response'}, - remoteip => $ENV{'REMOTE_ADDR'}, + remoteip => $ip, ); my $request=new HTTP::Request('POST','https://www.google.com/recaptcha/api/siteverify'); $request->content(join('&',map { @@ -17669,7 +18422,7 @@ sub check_recaptcha { my $captcha_result = $captcha->check_answer( $privkey, - $ENV{'REMOTE_ADDR'}, + $ip, $env{'form.recaptcha_challenge_field'}, $env{'form.recaptcha_response_field'}, ); @@ -17721,6 +18474,9 @@ sub cleanup_html { # $context is the calling context -- roles, grades, contents, menu or flip. sub critical_redirect { my ($interval,$context) = @_; + unless (($env{'user.domain'} ne '') && ($env{'user.name'} ne '')) { + return (); + } if ((time-$env{'user.criticalcheck.time'})>$interval) { if (($env{'request.course.id'}) && (($context eq 'flip') || ($context eq 'contents'))) { my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; @@ -17742,7 +18498,7 @@ sub critical_redirect { &Apache::lonnet::appenv({'user.criticalcheck.time'=>time}); my $redirecturl; if ($what[0]) { - if (($what[0] ne 'con_lost') && ($what[0]!~/^error\:/)) { + if (($what[0] ne 'con_lost') && ($what[0] ne 'no_such_host') && ($what[0]!~/^error\:/)) { $redirecturl='/adm/email?critical=display'; my $url=&Apache::lonnet::absolute_url().$redirecturl; return (1, $url); @@ -17802,6 +18558,339 @@ sub des_decrypt { return $plaintext; } +sub get_requested_shorturls { + my ($cdom,$cnum,$navmap) = @_; + return unless (ref($navmap)); + my ($numnew,$errors); + my @toshorten = &Apache::loncommon::get_env_multiple('form.addtiny'); + if (@toshorten) { + my (%maps,%resources,%titles); + &Apache::loncourserespicker::enumerate_course_contents($navmap,\%maps,\%resources,\%titles, + 'shorturls',$cdom,$cnum); + if (keys(%resources)) { + my %tocreate; + foreach my $item (sort {$a <=> $b} (@toshorten)) { + my $symb = $resources{$item}; + if ($symb) { + $tocreate{$cnum.'&'.$symb} = 1; + } + } + if (keys(%tocreate)) { + ($numnew,$errors) = &make_short_symbs($cdom,$cnum, + \%tocreate); + } + } + } + return ($numnew,$errors); +} + +sub make_short_symbs { + my ($cdom,$cnum,$tocreateref,$lockuser) = @_; + my ($numnew,@errors); + if (ref($tocreateref) eq 'HASH') { + my %tocreate = %{$tocreateref}; + if (keys(%tocreate)) { + my %coursetiny = &Apache::lonnet::dump('tiny',$cdom,$cnum); + my $su = Short::URL->new(no_vowels => 1); + my $init = ''; + my (%newunique,%addcourse,%courseonly,%failed); + # get lock on tiny db + my $now = time; + if ($lockuser eq '') { + $lockuser = $env{'user.name'}.':'.$env{'user.domain'}; + } + my $lockhash = { + "lock\0$now" => $lockuser, + }; + my $tries = 0; + my $gotlock = &Apache::lonnet::newput_dom('tiny',$lockhash,$cdom); + my ($code,$error); + while (($gotlock ne 'ok') && ($tries<3)) { + $tries ++; + sleep 1; + $gotlock = &Apache::lonnet::newput_dom('tiny',$lockhash,$cdom); + } + if ($gotlock eq 'ok') { + $init = &shorten_symbs($cdom,$init,$su,\%coursetiny,\%tocreate,\%newunique, + \%addcourse,\%courseonly,\%failed); + if (keys(%failed)) { + my $numfailed = scalar(keys(%failed)); + push(@errors,&mt('error: could not obtain unique six character URL for [quant,_1,resource]',$numfailed)); + } + if (keys(%newunique)) { + my $putres = &Apache::lonnet::newput_dom('tiny',\%newunique,$cdom); + if ($putres eq 'ok') { + $numnew = scalar(keys(%newunique)); + my $newputres = &Apache::lonnet::newput('tiny',\%addcourse,$cdom,$cnum); + unless ($newputres eq 'ok') { + push(@errors,&mt('error: could not store course look-up of short URLs')); + } + } else { + push(@errors,&mt('error: could not store unique six character URLs')); + } + } + my $dellockres = &Apache::lonnet::del_dom('tiny',["lock\0$now"],$cdom); + unless ($dellockres eq 'ok') { + push(@errors,&mt('error: could not release lockfile')); + } + } else { + push(@errors,&mt('error: could not obtain lockfile')); + } + if (keys(%courseonly)) { + my $result = &Apache::lonnet::newput('tiny',\%courseonly,$cdom,$cnum); + if ($result ne 'ok') { + push(@errors,&mt('error: could not update course look-up of short URLs')); + } + } + } + } + return ($numnew,\@errors); +} + +sub shorten_symbs { + my ($cdom,$init,$su,$coursetiny,$tocreate,$newunique,$addcourse,$courseonly,$failed) = @_; + return unless ((ref($su)) && (ref($coursetiny) eq 'HASH') && (ref($tocreate) eq 'HASH') && + (ref($newunique) eq 'HASH') && (ref($addcourse) eq 'HASH') && + (ref($courseonly) eq 'HASH') && (ref($failed) eq 'HASH')); + my (%possibles,%collisions); + foreach my $key (keys(%{$tocreate})) { + my $num = String::CRC32::crc32($key); + my $tiny = $su->encode($num,$init); + if ($tiny) { + $possibles{$tiny} = $key; + } + } + if (!$init) { + $init = 1; + } else { + $init ++; + } + if (keys(%possibles)) { + my @posstiny = keys(%possibles); + my $configuname = &Apache::lonnet::get_domainconfiguser($cdom); + my %currtiny = &Apache::lonnet::get('tiny',\@posstiny,$cdom,$configuname); + if (keys(%currtiny)) { + foreach my $key (keys(%currtiny)) { + next if ($currtiny{$key} eq ''); + if ($currtiny{$key} eq $possibles{$key}) { + my ($tcnum,$tsymb) = split(/\&/,$currtiny{$key}); + unless (($coursetiny->{$tsymb} eq $key) || ($addcourse->{$tsymb} eq $key) || ($courseonly->{$tsymb} eq $key)) { + $courseonly->{$tsymb} = $key; + } + } else { + $collisions{$possibles{$key}} = 1; + } + delete($possibles{$key}); + } + } + foreach my $key (keys(%possibles)) { + $newunique->{$key} = $possibles{$key}; + my ($tcnum,$tsymb) = split(/\&/,$possibles{$key}); + unless (($coursetiny->{$tsymb} eq $key) || ($addcourse->{$tsymb} eq $key) || ($courseonly->{$tsymb} eq $key)) { + $addcourse->{$tsymb} = $key; + } + } + } + if (keys(%collisions)) { + if ($init <5) { + if (!$init) { + $init = 1; + } else { + $init ++; + } + $init = &shorten_symbs($cdom,$init,$su,$coursetiny,\%collisions, + $newunique,$addcourse,$courseonly,$failed); + } else { + foreach my $key (keys(%collisions)) { + $failed->{$key} = 1; + } + } + } + return $init; +} + +sub is_nonframeable { + my ($url,$absolute,$hostname,$ip,$nocache) = @_; + my ($remprotocol,$remhost) = ($url =~ m{^(https?)\://(([a-z0-9]+(-[a-z0-9]+)*\.)+[a-z]{2,})}i); + return if (($remprotocol eq '') || ($remhost eq '')); + + $remprotocol = lc($remprotocol); + $remhost = lc($remhost); + my $remport = 80; + if ($remprotocol eq 'https') { + $remport = 443; + } + my ($result,$cached) = &Apache::lonnet::is_cached_new('noiframe',$remhost.':'.$remport); + if ($cached) { + unless ($nocache) { + if ($result) { + return 1; + } else { + return 0; + } + } + } + my $uselink; + my $request = new HTTP::Request('HEAD',$url); + my $response = &LONCAPA::LWPReq::makerequest('',$request,'','',5); + if ($response->is_success()) { + my $secpolicy = lc($response->header('content-security-policy')); + my $xframeop = lc($response->header('x-frame-options')); + $secpolicy =~ s/^\s+|\s+$//g; + $xframeop =~ s/^\s+|\s+$//g; + if (($secpolicy ne '') || ($xframeop ne '')) { + my $remotehost = $remprotocol.'://'.$remhost; + my ($origin,$protocol,$port); + if ($ENV{'SERVER_PORT'} =~/^\d+$/) { + $port = $ENV{'SERVER_PORT'}; + } else { + $port = 80; + } + if ($absolute eq '') { + $protocol = 'http:'; + if ($port == 443) { + $protocol = 'https:'; + } + $origin = $protocol.'//'.lc($hostname); + } else { + $origin = lc($absolute); + ($protocol,$hostname) = ($absolute =~ m{^(https?:)//([^/]+)$}); + } + if (($secpolicy) && ($secpolicy =~ /\Qframe-ancestors\E([^;]*)(;|$)/)) { + my $framepolicy = $1; + $framepolicy =~ s/^\s+|\s+$//g; + my @policies = split(/\s+/,$framepolicy); + if (@policies) { + if (grep(/^\Q'none'\E$/,@policies)) { + $uselink = 1; + } else { + $uselink = 1; + if ((grep(/^\Q*\E$/,@policies)) || (grep(/^\Q$protocol\E$/,@policies)) || + (($origin ne '') && (grep(/^\Q$origin\E$/,@policies))) || + (($ip ne '') && (grep(/^\Q$ip\E$/,@policies)))) { + undef($uselink); + } + if ($uselink) { + if (grep(/^\Q'self'\E$/,@policies)) { + if (($origin ne '') && ($remotehost eq $origin)) { + undef($uselink); + } + } + } + if ($uselink) { + my @possok; + if ($ip ne '') { + push(@possok,$ip); + } + my $hoststr = ''; + foreach my $part (reverse(split(/\./,$hostname))) { + if ($hoststr eq '') { + $hoststr = $part; + } else { + $hoststr = "$part.$hoststr"; + } + if ($hoststr eq $hostname) { + push(@possok,$hostname); + } else { + push(@possok,"*.$hoststr"); + } + } + if (@possok) { + foreach my $poss (@possok) { + last if (!$uselink); + foreach my $policy (@policies) { + if ($policy =~ m{^(\Q$protocol\E//|)\Q$poss\E(\Q:$port\E|)$}) { + undef($uselink); + last; + } + } + } + } + } + } + } + } elsif ($xframeop ne '') { + $uselink = 1; + my @policies = split(/\s*,\s*/,$xframeop); + if (@policies) { + unless (grep(/^deny$/,@policies)) { + if ($origin ne '') { + if (grep(/^sameorigin$/,@policies)) { + if ($remotehost eq $origin) { + undef($uselink); + } + } + if ($uselink) { + foreach my $policy (@policies) { + if ($policy =~ /^allow-from\s*(.+)$/) { + my $allowfrom = $1; + if (($allowfrom ne '') && ($allowfrom eq $origin)) { + undef($uselink); + last; + } + } + } + } + } + } + } + } + } + } + if ($nocache) { + if ($cached) { + my $devalidate; + if ($uselink && !$result) { + $devalidate = 1; + } elsif (!$uselink && $result) { + $devalidate = 1; + } + if ($devalidate) { + &Apache::lonnet::devalidate_cache_new('noiframe',$remhost.':'.$remport); + } + } + } else { + if ($uselink) { + $result = 1; + } else { + $result = 0; + } + &Apache::lonnet::do_cache_new('noiframe',$remhost.':'.$remport,$result,3600); + } + return $uselink; +} + +sub page_menu { + my ($menucolls,$menunum) = @_; + my %menu; + foreach my $item (split(/;/,$menucolls)) { + my ($num,$value) = split(/\%/,$item); + if ($num eq $menunum) { + my @entries = split(/\&/,$value); + foreach my $entry (@entries) { + my ($name,$fields) = split(/=/,$entry); + if (($name eq 'top') || ($name eq 'inline') || ($name eq 'foot') || ($name eq 'main')) { + $menu{$name} = $fields; + } else { + my @shown; + if ($fields =~ /,/) { + @shown = split(/,/,$fields); + } else { + @shown = ($fields); + } + if (@shown) { + foreach my $field (@shown) { + next if ($field eq ''); + $menu{$field} = 1; + } + } + } + } + } + } + return %menu; +} + 1; __END__;