--- loncom/lonnet/perl/lonnet.pm	2012/03/31 23:10:55	1.1162
+++ loncom/lonnet/perl/lonnet.pm	2012/05/18 15:31:40	1.1168
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.1162 2012/03/31 23:10:55 raeburn Exp $
+# $Id: lonnet.pm,v 1.1168 2012/05/18 15:31:40 www Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -97,6 +97,7 @@ use File::MMagic;
 use LONCAPA qw(:DEFAULT :match);
 use LONCAPA::Configuration;
 use LONCAPA::lonmetadata;
+use LONCAPA::Lond;
 
 use File::Copy;
 
@@ -1535,16 +1536,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   
@@ -2158,8 +2156,7 @@ sub getsection {
     # If there is a role which has expired, return it.
     #
     $courseid = &courseid_to_courseurl($courseid);
-    my $extra = &freeze_escape({'skipcheck' => 1});
-    my %roleshash = &dump('roles',$udom,$unam,$courseid,undef,$extra);
+    my %roleshash = &dump('roles',$udom,$unam,$courseid);
     foreach my $key (keys(%roleshash)) {
         next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/);
         my $section=$1;
@@ -2443,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);
@@ -3033,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 => '',
@@ -3062,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') {
@@ -3078,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'});
@@ -3087,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)) {
@@ -3107,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 '') {
@@ -3127,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';
 }
 
@@ -3141,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);    
@@ -3548,8 +3620,7 @@ sub get_my_roles {
     unless (defined($udom)) { $udom=$env{'user.domain'}; }
     my (%dumphash,%nothide);
     if ($context eq 'userroles') {
-        my $extra = &freeze_escape({'skipcheck' => 1});
-        %dumphash = &dump('roles',$udom,$uname,'.',undef,$extra);
+        %dumphash = &dump('roles',$udom,$uname);
     } else {
         %dumphash=
             &dump('nohist_userroles',$udom,$uname);
@@ -4577,8 +4648,7 @@ sub rolesinit {
     my ($domain,$username,$authhost)=@_;
     my $now=time;
     my %userroles = ('user.login.time' => $now);
-    my $extra = &freeze_escape({'skipcheck' => 1});
-    my $rolesdump=reply("dump:$domain:$username:roles:.::$extra",$authhost);
+    my $rolesdump=reply("dump:$domain:$username:roles",$authhost);
     if (($rolesdump eq 'con_lost') || ($rolesdump eq '') || 
         ($rolesdump =~ /^error:/)) {
         return \%userroles;
@@ -4604,7 +4674,9 @@ sub rolesinit {
             my ($area,$role)=split(/=/,$entry);
 	    $area=~s/\_\w\w$//;
             my ($trole,$tend,$tstart,$group_privs);
-	    if ($role=~/^cr/) { 
+	    if ($role=~/^cr/) {
+# Custom role, defined by a user 
+# e.g., user.role.cr/msu/smith/mynewrole
 		if ($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|) {
 		    ($trole,my $trest)=($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|);
 		    ($tend,$tstart)=split('_',$trest);
@@ -4612,11 +4684,14 @@ sub rolesinit {
 		    $trole=$role;
 		}
             } elsif ($role =~ m|^gr/|) {
+# Role of member in a group, defined within a course/community
+# e.g., user.role.gr/msu/04935610a19ee4a5fmsul1/leopards
                 ($trole,$tend,$tstart) = split(/_/,$role);
                 next if ($tstart eq '-1');
                 ($trole,$group_privs) = split(/\//,$trole);
                 $group_privs = &unescape($group_privs);
 	    } else {
+# Just a normal role, defined in roles.tab
 		($trole,$tend,$tstart)=split(/_/,$role);
 	    }
 	    my %new_role = &set_arearole($trole,$area,$tstart,$tend,$domain,
@@ -4628,10 +4703,13 @@ sub rolesinit {
 		my $spec=$trole.'.'.$area;
 		my ($tdummy,$tdomain,$trest)=split(/\//,$area);
 		if ($trole =~ /^cr\//) {
+# Custom role, defined by a user
                     &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
                 } elsif ($trole eq 'gr') {
+# Role of a member in a group, defined within a course/community
                     &group_roleprivs(\%allgroups,$area,$group_privs,$tend,$tstart);
 		} else {
+# Normal role, defined in roles.tab
                     &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
 		}
                 if ($trole ne 'gr') {
@@ -4998,16 +5076,17 @@ sub del {
 # -------------------------------------------------------------- dump interface
 
 sub dump {
-    my ($namespace,$udomain,$uname,$regexp,$range,$extra)=@_;
+    my ($namespace,$udomain,$uname,$regexp,$range)=@_;
     if (!$udomain) { $udomain=$env{'user.domain'}; }
     if (!$uname) { $uname=$env{'user.name'}; }
     my $uhome=&homeserver($uname,$udomain);
+
     if ($regexp) {
 	$regexp=&escape($regexp);
     } else {
 	$regexp='.';
     }
-    my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range:$extra",$uhome);
+    my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
     my @pairs=split(/\&/,$rep);
     my %returnhash=();
     if (!($rep =~ /^error/ )) {
@@ -6365,6 +6444,7 @@ sub has_comm_blocking {
                   );
     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);
@@ -6390,6 +6470,7 @@ sub has_comm_blocking {
             }
         } 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;
@@ -6403,14 +6484,17 @@ sub has_comm_blocking {
                             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) {
-                                    my $navmap = Apache::lonnavmaps::navmap->new();
                                     if (ref($navmap)) {
                                         my $mapres = $navmap->getBySymb($mapsymb);
-                                        my @resources = $mapres->retrieveResources($mapres,undef,0,1);
-                                        foreach my $res (@resources) {
+                                        @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 '') {
@@ -6434,8 +6518,15 @@ sub has_comm_blocking {
                             if ($first_access) {
                                 my $timesup = $first_access+$interval[0];
                                 if ($timesup > $now) {
-                                    unless (grep(/^\Q$block\E$/,@blockers)) {
-                                        push(@blockers,$block);
+                                    foreach my $res (@to_test) {
+                                        if ($res->is_problem()) {
+                                            if ($res->completable()) {
+                                                unless (grep(/^\Q$block\E$/,@blockers)) {
+                                                    push(@blockers,$block);
+                                                }
+                                                last;
+                                            }
+                                        }
                                     }
                                 }
                             }
@@ -7205,8 +7296,7 @@ sub get_users_groups {
     } else {  
         $grouplist = '';
         my $courseurl = &courseid_to_courseurl($courseid);
-        my $extra = &freeze_escape({'skipcheck' => 1});
-        my %roleshash = &dump('roles',$udom,$uname,$courseurl,undef,$extra);
+        my %roleshash = &dump('roles',$udom,$uname,$courseurl);
         my $access_end = $env{'course.'.$courseid.
                               '.default_enrollment_end_date'};
         my $now = time;
@@ -8019,13 +8109,16 @@ sub generate_coursenum {
 }
 
 sub is_course {
-    my ($cdom,$cnum) = @_;
-    my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,
-				undef,'.');
-    if (exists($courses{$cdom.'_'.$cnum})) {
-        return 1;
-    }
-    return 0;
+    my ($cdom, $cnum) = scalar(@_) == 1 ? 
+         ($_[0] =~ /^($match_domain)_($match_courseid)$/)  :  @_;
+
+    return unless $cdom and $cnum;
+
+    my %courses = &courseiddump($cdom, '.', 1, '.', '.', $cnum, undef, undef,
+        '.');
+
+    return unless exists($courses{$cdom.'_'.$cnum});
+    return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum;
 }
 
 sub store_userdata {
@@ -10428,7 +10521,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";
@@ -11896,6 +11989,19 @@ createcourse($udom,$description,$url,$co
 
 generate_coursenum($udom,$crstype) : get a unique (unused) course number in domain $udom for course type $crstype (Course or Community).
 
+=item *
+
+is_course($courseid), is_course($cdom, $cnum)
+
+Accepts either a combined $courseid (in the form of domain_courseid) or the
+two component version $cdom, $cnum. It checks if the specified course exists.
+
+Returns:
+    undef if the course doesn't exist, otherwise
+    in scalar context the combined courseid.
+    in list context the two components of the course identifier, domain and 
+    courseid.    
+
 =back
 
 =head2 Resource Subroutines