--- loncom/lonnet/perl/lonnet.pm	2012/03/14 20:53:50	1.1158
+++ loncom/lonnet/perl/lonnet.pm	2012/04/24 20:31:59	1.1165
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.1158 2012/03/14 20:53:50 www Exp $
+# $Id: lonnet.pm,v 1.1165 2012/04/24 20:31:59 droeschl Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -96,6 +96,7 @@ use Math::Random;
 use File::MMagic;
 use LONCAPA qw(:DEFAULT :match);
 use LONCAPA::Configuration;
+use LONCAPA::lonmetadata;
 
 use File::Copy;
 
@@ -1534,16 +1535,13 @@ sub idput {
 
 # ------------------------------dump from db file owned by domainconfig user
 sub dump_dom {
-    my ($namespace,$udom,$regexp,$range)=@_;
-    if (!$udom) {
-        $udom=$env{'user.domain'};
-    }
-    my %returnhash;
-    if ($udom) {
-        my $uname = &get_domainconfiguser($udom);
-        %returnhash = &dump($namespace,$udom,$uname,$regexp,$range);
-    }
-    return %returnhash;
+    my ($namespace, $udom, $regexp) = @_;
+
+    $udom ||= $env{'user.domain'};
+
+    return () unless $udom;
+
+    return &dump($namespace, $udom, &get_domainconfiguser($udom), $regexp);
 }
 
 # ------------------------------------------ get items from domain db files   
@@ -2442,7 +2440,7 @@ sub repcopy {
     $filename=~s/\/+/\//g;
     my $londocroot = $perlvar{'lonDocRoot'};
     if ($filename=~m{^\Q$londocroot/adm/\E}) { return 'ok'; }
-    if ($filename=~m{^\Q$londocroot/lonUsers/\E}) { return 'ok'; }
+    if ($filename=~m{^\Q/home/httpd/lonUsers/\E}) { return 'ok'; }
     if ($filename=~m{^\Q$londocroot/userfiles/\E} or
 	$filename=~m{^/*(uploaded|editupload)/}) {
 	return &repcopy_userfile($filename);
@@ -3032,6 +3030,7 @@ sub finishuserfileupload {
 sub extract_embedded_items {
     my ($fullpath,$allfiles,$codebase,$content) = @_;
     my @state = ();
+    my (%lastids,%related,%shockwave,%flashvars);
     my %javafiles = (
                       codebase => '',
                       code => '',
@@ -3061,10 +3060,30 @@ sub extract_embedded_items {
 		&add_filetype($allfiles,$attr->{'href'},'href');
 	    }
             if (lc($tagname) eq 'script') {
+                my $src;
                 if ($attr->{'archive'} =~ /\.jar$/i) {
                     &add_filetype($allfiles,$attr->{'archive'},'archive');
                 } else {
-                    &add_filetype($allfiles,$attr->{'src'},'src');
+                    if ($attr->{'src'} ne '') {
+                        $src = $attr->{'src'};
+                        &add_filetype($allfiles,$src,'src');
+                    }
+                }
+                my $text = $p->get_trimmed_text();
+                if ($text =~ /\Qswfobject.registerObject(\E([^\)]+)\)/) {
+                    my @swfargs = split(/,/,$1);
+                    foreach my $item (@swfargs) {
+                        $item =~ s/["']//g;
+                        $item =~ s/^\s+//;
+                        $item =~ s/\s+$//;
+                    }
+                    if (($swfargs[0] ne'') && ($swfargs[2] ne '')) {
+                        if (ref($related{$swfargs[0]}) eq 'ARRAY') {
+                            push(@{$related{$swfargs[0]}},$swfargs[2]);
+                        } else {
+                            $related{$swfargs[0]} = [$swfargs[2]];
+                        }
+                    }
                 }
             }
             if (lc($tagname) eq 'link') {
@@ -3077,6 +3096,9 @@ sub extract_embedded_items {
 		foreach my $item (keys(%javafiles)) {
 		    $javafiles{$item} = '';
 		}
+                if ((lc($tagname) eq 'object') && (lc($state[-2]) ne 'object')) {
+                    $lastids{lc($tagname)} = $attr->{'id'};
+                }
 	    }
 	    if (lc($state[-2]) eq 'object' && lc($tagname) eq 'param') {
 		my $name = lc($attr->{'name'});
@@ -3086,12 +3108,22 @@ sub extract_embedded_items {
 			last;
 		    }
 		}
+                my $pathfrom;
 		foreach my $item (keys(%mediafiles)) {
 		    if ($name eq $item) {
-			&add_filetype($allfiles, $attr->{'value'}, 'value');
+                        $pathfrom = $attr->{'value'};
+                        $shockwave{$lastids{lc($state[-2])}} = $pathfrom;
+			&add_filetype($allfiles,$pathfrom,$name);
 			last;
 		    }
 		}
+                if ($name eq 'flashvars') {
+                    $flashvars{$lastids{lc($state[-2])}} = $attr->{'value'};
+                }
+                if ($pathfrom ne '') {
+                    &embedded_dependency($allfiles,\%related,$lastids{lc($state[-2])},
+                                         $pathfrom);
+                }
 	    }
 	    if (lc($tagname) eq 'embed' || lc($tagname) eq 'applet') {
 		foreach my $item (keys(%javafiles)) {
@@ -3106,7 +3138,16 @@ sub extract_embedded_items {
 			last;
 		    }
 		}
+                if (lc($tagname) eq 'embed') {
+                    if (($attr->{'name'} ne '') && ($attr->{'src'} ne '')) {
+                        &embedded_dependency($allfiles,\%related,$attr->{'name'},
+                                             $attr->{'src'});
+                    }
+                }
 	    }
+            if ($t->[4] =~ m{/>$}) {
+                pop(@state);  
+            }
 	} elsif ($t->[0] eq 'E') {
 	    my ($tagname) = ($t->[1]);
 	    if ($javafiles{'codebase'} ne '') {
@@ -3126,6 +3167,23 @@ sub extract_embedded_items {
 	    pop @state;
 	}
     }
+    foreach my $id (sort(keys(%flashvars))) {
+        if ($shockwave{$id} ne '') {
+            my @pairs = split(/\&/,$flashvars{$id});
+            foreach my $pair (@pairs) {
+                my ($key,$value) = split(/\=/,$pair);
+                if ($key eq 'thumb') {
+                    &add_filetype($allfiles,$value,$key);
+                } elsif ($key eq 'content') {
+                    my ($path) = ($shockwave{$id} =~ m{^(.+/)[^/]+$});
+                    my ($ext) = ($value =~ /\.([^.]+)$/);
+                    if ($ext ne '') {
+                        &add_filetype($allfiles,$path.$value,$ext);
+                    }
+                }
+            }
+        }
+    }
     return 'ok';
 }
 
@@ -3140,6 +3198,21 @@ sub add_filetype {
     }
 }
 
+sub embedded_dependency {
+    my ($allfiles,$related,$identifier,$pathfrom) = @_;
+    if ((ref($allfiles) eq 'HASH') && (ref($related) eq 'HASH')) {
+        if (($identifier ne '') &&
+            (ref($related->{$identifier}) eq 'ARRAY') &&
+            ($pathfrom ne '')) {
+            my ($path) = ($pathfrom =~ m{^(.+/)[^/]+$});
+            foreach my $dep (@{$related->{$identifier}}) {
+                &add_filetype($allfiles,$path.$dep,'object');
+            }
+        }
+    }
+    return;
+}
+
 sub removeuploadedurl {
     my ($url)=@_;	
     my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);    
@@ -3269,6 +3342,7 @@ sub flushcourselogs {
             }
         } else {
             my ($dom,$name) = ($entry=~m{___($match_domain)/($match_name)/(.*)___(\w+)$});
+            if (($dom eq 'uploaded') || ($dom eq 'adm')) { next; }
             my %temphash=($entry => $accesshash{$entry});
             if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {
                 delete $accesshash{$entry};
@@ -3397,6 +3471,22 @@ sub linklog {
     $accesshash{$from.'___'.$to.'___comefrom'}=1;
     $accesshash{$to.'___'.$from.'___goto'}=1;
 }
+
+sub statslog {
+    my ($symb,$part,$users,$av_attempts,$degdiff)=@_;
+    if ($users<2) { return; }
+    my %dynstore=&LONCAPA::lonmetadata::dynamic_metadata_storage({
+            'course'       => $env{'request.course.id'},
+            'sections'     => '"all"',
+            'num_students' => $users,
+            'part'         => $part,
+            'symb'         => $symb,
+            'mean_tries'   => $av_attempts,
+            'deg_of_diff'  => $degdiff});
+    foreach my $key (keys(%dynstore)) {
+        $accesshash{$key}=$dynstore{$key};
+    }
+}
   
 sub userrolelog {
     my ($trole,$username,$domain,$area,$tstart,$tend)=@_;
@@ -3889,10 +3979,11 @@ sub load_all_first_access {
 }
 
 sub get_first_access {
-    my ($type,$argsymb)=@_;
+    my ($type,$argsymb,$argmap)=@_;
     my ($symb,$courseid,$udom,$uname)=&whichuser();
     if ($argsymb) { $symb=$argsymb; }
     my ($map,$id,$res)=&decode_symb($symb);
+    if ($argmap) { $map = $argmap; }
     if ($type eq 'course') {
 	$res='course';
     } elsif ($type eq 'map') {
@@ -3905,7 +3996,7 @@ sub get_first_access {
 }
 
 sub set_first_access {
-    my ($type)=@_;
+    my ($type,$interval)=@_;
     my ($symb,$courseid,$udom,$uname)=&whichuser();
     my ($map,$id,$res)=&decode_symb($symb);
     if ($type eq 'course') {
@@ -3916,9 +4007,22 @@ sub set_first_access {
 	$res=$symb;
     }
     $cachedkey='';
-    my $firstaccess=&get_first_access($type,$symb);
+    my $firstaccess=&get_first_access($type,$symb,$map);
     if (!$firstaccess) {
-	return &put('firstaccesstimes',{"$courseid\0$res"=>time},$udom,$uname);
+        my $start = time;
+	my $putres = &put('firstaccesstimes',{"$courseid\0$res"=>$start},
+                          $udom,$uname);
+        if ($putres eq 'ok') {
+            &put('timerinterval',{"$courseid\0$res"=>$interval},
+                 $udom,$uname); 
+            &appenv(
+                     {
+                        'course.'.$courseid.'.firstaccess.'.$res   => $start,
+                        'course.'.$courseid.'.timerinterval.'.$res => $interval,
+                     }
+                  );
+        }
+        return $putres;
     }
     return 'already_set';
 }
@@ -4551,8 +4655,20 @@ sub rolesinit {
         ($rolesdump =~ /^error:/)) {
         return \%userroles;
     }
+    my %firstaccess = &dump('firstaccesstimes',$domain,$username);
+    my %timerinterval = &dump('timerinterval',$domain,$username);
+    my (%coursetimerstarts,%firstaccchk,%firstaccenv,
+        %coursetimerintervals,%timerintchk,%timerintenv);
+    foreach my $key (keys(%firstaccess)) {
+        my ($cid,$rest) = split(/\0/,$key);
+        $coursetimerstarts{$cid}{$rest} = $firstaccess{$key};
+    }
+    foreach my $key (keys(%timerinterval)) {
+        my ($cid,$rest) = split(/\0/,$key);
+        $coursetimerintervals{$cid}{$rest} = $timerinterval{$key};
+    }
     my %allroles=();
-    my %allgroups=();   
+    my %allgroups=();
 
     if ($rolesdump ne '') {
         foreach my $entry (split(/&/,$rolesdump)) {
@@ -4590,6 +4706,27 @@ sub rolesinit {
 		} else {
                     &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
 		}
+                if ($trole ne 'gr') {
+                    my $cid = $tdomain.'_'.$trest;
+                    unless ($firstaccchk{$cid}) {
+                        if (ref($coursetimerstarts{$cid}) eq 'HASH') {
+                            foreach my $item (keys(%{$coursetimerstarts{$cid}})) {
+                                $firstaccenv{'course.'.$cid.'.firstaccess.'.$item} = 
+                                    $coursetimerstarts{$cid}{$item}; 
+                            }
+                        }
+                        $firstaccchk{$cid} = 1;
+                    }
+                    unless ($timerintchk{$cid}) {
+                        if (ref($coursetimerintervals{$cid}) eq 'HASH') {
+                            foreach my $item (keys(%{$coursetimerintervals{$cid}})) {
+                                $timerintenv{'course.'.$cid.'.timerinterval.'.$item} =
+                                   $coursetimerintervals{$cid}{$item};
+                            }
+                        }
+                        $timerintchk{$cid} = 1;
+                    }
+                }
             }
           }
         }
@@ -4598,7 +4735,7 @@ sub rolesinit {
 	$userroles{'user.author'} = $author;
         $env{'user.adv'}=$adv;
     }
-    return \%userroles;  
+    return (\%userroles,\%firstaccenv,\%timerintenv);
 }
 
 sub set_arearole {
@@ -5979,7 +6116,12 @@ sub allowed {
         if ($match) {
             if ($env{'user.priv.'.$env{'request.role'}.'./'}
                   =~/\Q$priv\E\&([^\:]*)/) {
-                $thisallowed.=$1;
+                my @blockers = &has_comm_blocking($priv,$symb,$uri);
+                if (@blockers > 0) {
+                    $thisallowed = 'B';
+                } else {
+                    $thisallowed.=$1;
+                }
             }
         } else {
             my $refuri = $env{'httpref.'.$orguri} || $env{'httpref.'.$ver_orguri};
@@ -5990,7 +6132,12 @@ sub allowed {
                     $refuri=&declutter($refuri);
                     my ($match) = &is_on_map($refuri);
                     if ($match) {
-                        $thisallowed='F';
+                        my @blockers = &has_comm_blocking($priv,$symb,$refuri);
+                        if (@blockers > 0) {
+                            $thisallowed = 'B';
+                        } else {
+                            $thisallowed='F';
+                        }
                     }
                 }
             }
@@ -6042,7 +6189,17 @@ sub allowed {
            $statecond=$cond;
            if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid}
                =~/\Q$priv\E\&([^\:]*)/) {
-               $thisallowed.=$1;
+               my $value = $1;
+               if ($priv eq 'bre') {
+                   my @blockers = &has_comm_blocking($priv,$symb,$uri);
+                   if (@blockers > 0) {
+                       $thisallowed = 'B';
+                   } else {
+                       $thisallowed.=$value;
+                   }
+               } else {
+                   $thisallowed.=$value;
+               }
                $checkreferer=0;
            }
        }
@@ -6070,7 +6227,17 @@ sub allowed {
               my $refstatecond=$cond;
               if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid}
                   =~/\Q$priv\E\&([^\:]*)/) {
-                  $thisallowed.=$1;
+                  my $value = $1;
+                  if ($priv eq 'bre') {
+                      my @blockers = &has_comm_blocking($priv,$symb,$refuri);
+                      if (@blockers > 0) {
+                          $thisallowed = 'B';
+                      } else {
+                          $thisallowed.=$value;
+                      }
+                  } else {
+                      $thisallowed.=$value;
+                  }
                   $uri=$refuri;
                   $statecond=$refstatecond;
               }
@@ -6229,6 +6396,164 @@ sub allowed {
     }
    return 'F';
 }
+
+sub get_comm_blocks {
+    my ($cdom,$cnum) = @_;
+    if ($cdom eq '' || $cnum eq '') {
+        return unless ($env{'request.course.id'});
+        $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
+        $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
+    }
+    my %commblocks;
+    my $hashid=$cdom.'_'.$cnum;
+    my ($blocksref,$cached)=&is_cached_new('comm_block',$hashid);
+    if ((defined($cached)) && (ref($blocksref) eq 'HASH')) {
+        %commblocks = %{$blocksref};
+    } else {
+        %commblocks = &Apache::lonnet::dump('comm_block',$cdom,$cnum);
+        my $cachetime = 600;
+        &do_cache_new('comm_block',$hashid,\%commblocks,$cachetime);
+    }
+    return %commblocks;
+}
+
+sub has_comm_blocking {
+    my ($priv,$symb,$uri,$blocks) = @_;
+    return unless ($env{'request.course.id'});
+    return unless ($priv eq 'bre');
+    return if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/);
+    my %commblocks;
+    if (ref($blocks) eq 'HASH') {
+        %commblocks = %{$blocks};
+    } else {
+        %commblocks = &get_comm_blocks();
+    }
+    return unless (keys(%commblocks) > 0);
+    if (!$symb) { $symb=&symbread($uri,1); }
+    my ($map,$resid,undef)=&decode_symb($symb);
+    my %tocheck = (
+                    maps      => $map,
+                    resources => $symb,
+                  );
+    my @blockers;
+    my $now = time;
+    my $navmap = Apache::lonnavmaps::navmap->new();
+    foreach my $block (keys(%commblocks)) {
+        if ($block =~ /^(\d+)____(\d+)$/) {
+            my ($start,$end) = ($1,$2);
+            if ($start <= $now && $end >= $now) {
+                if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {
+                    if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {
+                        if (ref($commblocks{$block}{'blocks'}{'docs'}{'maps'}) eq 'HASH') {
+                            if ($commblocks{$block}{'blocks'}{'docs'}{'maps'}{$map}) {
+                                unless (grep(/^\Q$block\E$/,@blockers)) {
+                                    push(@blockers,$block);
+                                }
+                            }
+                        }
+                        if (ref($commblocks{$block}{'blocks'}{'docs'}{'resources'}) eq 'HASH') {
+                            if ($commblocks{$block}{'blocks'}{'docs'}{'resources'}{$symb}) {
+                                unless (grep(/^\Q$block\E$/,@blockers)) {  
+                                    push(@blockers,$block);
+                                }
+                            }
+                        }
+                    }
+                }
+            }
+        } elsif ($block =~ /^firstaccess____(.+)$/) {
+            my $item = $1;
+            my @to_test;
+            if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {
+                if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {
+                    my $check_interval;
+                    if (&check_docs_block($commblocks{$block}{'blocks'}{'docs'},\%tocheck)) {
+                        my @interval;
+                        my $type = 'map';
+                        if ($item eq 'course') {
+                            $type = 'course';
+                            @interval=&EXT("resource.0.interval");
+                        } else {
+                            if ($item =~ /___\d+___/) {
+                                $type = 'resource';
+                                @interval=&EXT("resource.0.interval",$item);
+                                if (ref($navmap)) {                        
+                                    my $res = $navmap->getBySymb($item); 
+                                    push(@to_test,$res);
+                                }
+                            } else {
+                                my $mapsymb = &symbread($item,1);
+                                if ($mapsymb) {
+                                    if (ref($navmap)) {
+                                        my $mapres = $navmap->getBySymb($mapsymb);
+                                        @to_test = $mapres->retrieveResources($mapres,undef,0,1);
+                                        foreach my $res (@to_test) {
+                                            my $symb = $res->symb();
+                                            next if ($symb eq $mapsymb);
+                                            if ($symb ne '') {
+                                                @interval=&EXT("resource.0.interval",$symb);
+                                                last;
+                                            }
+                                        }
+                                    }
+                                }
+                            }
+                        }
+                        if ($interval[0] =~ /\d+/) {
+                            my $first_access;
+                            if ($type eq 'resource') {
+                                $first_access=&get_first_access($interval[1],$item);
+                            } elsif ($type eq 'map') {
+                                $first_access=&get_first_access($interval[1],undef,$item);
+                            } else {
+                                $first_access=&get_first_access($interval[1]);
+                            }
+                            if ($first_access) {
+                                my $timesup = $first_access+$interval[0];
+                                if ($timesup > $now) {
+                                    foreach my $res (@to_test) {
+                                        if ($res->is_problem()) {
+                                            if ($res->completable()) {
+                                                unless (grep(/^\Q$block\E$/,@blockers)) {
+                                                    push(@blockers,$block);
+                                                }
+                                                last;
+                                            }
+                                        }
+                                    }
+                                }
+                            }
+                        }
+                    }
+                }
+            }
+        }
+    }
+    return @blockers;
+}
+
+sub check_docs_block {
+    my ($docsblock,$tocheck) =@_;
+    if ((ref($docsblock) ne 'HASH') || (ref($tocheck) ne 'HASH')) {
+        return;
+    }
+    if (ref($docsblock->{'maps'}) eq 'HASH') {
+        if ($tocheck->{'maps'}) {
+            if ($docsblock->{'maps'}{$tocheck->{'maps'}}) {
+                return 1;
+            }
+        }
+    }
+    if (ref($docsblock->{'resources'}) eq 'HASH') {
+        if ($tocheck->{'resources'}) {
+            if ($docsblock->{'resources'}{$tocheck->{'resources'}}) {
+                return 1;
+            }
+        }
+    }
+    return;
+}
+
 #
 #   Removes the versino from a URI and
 #   splits it in to its filename and path to the filename.
@@ -9404,6 +9729,10 @@ sub gettitle {
 	}
 	$title=~s/\&colon\;/\:/gs;
 	if ($title) {
+# Remember both $symb and $title for dynamic metadata
+            $accesshash{$symb.'___crstitle'}=$title;
+            $accesshash{&declutter($map).'___'.&declutter($url).'___usage'}=time;
+# Cache this title and then return it
 	    return &do_cache_new('title',$key,$title,600);
 	}
 	$urlsymb=$url;
@@ -10183,7 +10512,7 @@ sub repcopy_userfile {
     my ($file)=@_;
     my $londocroot = $perlvar{'lonDocRoot'};
     if ($file =~ m{^/*(uploaded|editupload)/}) { $file=&filelocation("",$file); }
-    if ($file =~ m{^\Q$londocroot/lonUsers/\E}) { return 'ok'; }
+    if ($file =~ m{^\Q/home/httpd/lonUsers/\E}) { return 'ok'; }
     my ($cdom,$cnum,$filename) = 
 	($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)|);
     my $uri="/uploaded/$cdom/$cnum/$filename";