--- loncom/Lond.pm	2012/04/26 20:00:57	1.3
+++ loncom/Lond.pm	2012/07/17 14:49:39	1.4
@@ -1,6 +1,6 @@
 # The LearningOnline Network
 #
-# $Id: Lond.pm,v 1.3 2012/04/26 20:00:57 droeschl Exp $
+# $Id: Lond.pm,v 1.4 2012/07/17 14:49:39 droeschl Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -27,6 +27,7 @@
 ###
 
 #NOTE perldoc at the end of file
+#TODO move remaining lond functions into this
 
 package LONCAPA::Lond;
 
@@ -39,11 +40,11 @@ use GDBM_File;
 
 
 sub dump_with_regexp {
-    my ( $tail, $clientname, $clientversion ) = @_;
+    my ( $tail, $clientversion ) = @_;
     my ( $udom, $uname, $namespace, $regexp, $range ) = 
         split /:/, $tail;
 
-    $regexp = defined $regexp ? unescape($regexp) : '.';
+    $regexp = $regexp ? unescape($regexp) : '.';
 
     my ($start,$end);
 
@@ -79,6 +80,7 @@ sub dump_with_regexp {
         if ($clientversion =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?/) {
             $major = $1;
             $minor = $2;
+
         }
         if (($major > 2) || (($major == 2) && ($minor > 9))) {
             $skipcheck = 1;
@@ -325,7 +327,394 @@ sub get_courseinfo_hash {
     return;
 }
 
+sub dump_course_id_handler {
+    my ($tail) = @_;
+
+    my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter,
+        $typefilter,$regexp_ok,$rtn_as_hash,$selfenrollonly,$catfilter,$showhidden,
+        $caller,$cloner,$cc_clone_list,$cloneonly,$createdbefore,$createdafter,
+        $creationcontext,$domcloner) = split(/:/,$tail);
+    my $now = time;
+    my ($cloneruname,$clonerudom,%cc_clone);
+    if (defined($description)) {
+	$description=&unescape($description);
+    } else {
+	$description='.';
+    }
+    if (defined($instcodefilter)) {
+        $instcodefilter=&unescape($instcodefilter);
+    } else {
+        $instcodefilter='.';
+    }
+    my ($ownerunamefilter,$ownerdomfilter);
+    if (defined($ownerfilter)) {
+        $ownerfilter=&unescape($ownerfilter);
+        if ($ownerfilter ne '.' && defined($ownerfilter)) {
+            if ($ownerfilter =~ /^([^:]*):([^:]*)$/) {
+                 $ownerunamefilter = $1;
+                 $ownerdomfilter = $2;
+            } else {
+                $ownerunamefilter = $ownerfilter;
+                $ownerdomfilter = '';
+            }
+        }
+    } else {
+        $ownerfilter='.';
+    }
+
+    if (defined($coursefilter)) {
+        $coursefilter=&unescape($coursefilter);
+    } else {
+        $coursefilter='.';
+    }
+    if (defined($typefilter)) {
+        $typefilter=&unescape($typefilter);
+    } else {
+        $typefilter='.';
+    }
+    if (defined($regexp_ok)) {
+        $regexp_ok=&unescape($regexp_ok);
+    }
+    if (defined($catfilter)) {
+        $catfilter=&unescape($catfilter);
+    }
+    if (defined($cloner)) {
+        $cloner = &unescape($cloner);
+        ($cloneruname,$clonerudom) = ($cloner =~ /^($LONCAPA::match_username):($LONCAPA::match_domain)$/); 
+    }
+    if (defined($cc_clone_list)) {
+        $cc_clone_list = &unescape($cc_clone_list);
+        my @cc_cloners = split('&',$cc_clone_list);
+        foreach my $cid (@cc_cloners) {
+            my ($clonedom,$clonenum) = split(':',$cid);
+            next if ($clonedom ne $udom); 
+            $cc_clone{$clonedom.'_'.$clonenum} = 1;
+        } 
+    }
+    if ($createdbefore ne '') {
+        $createdbefore = &unescape($createdbefore);
+    } else {
+       $createdbefore = 0;
+    }
+    if ($createdafter ne '') {
+        $createdafter = &unescape($createdafter);
+    } else {
+        $createdafter = 0;
+    }
+    if ($creationcontext ne '') {
+        $creationcontext = &unescape($creationcontext);
+    } else {
+        $creationcontext = '.';
+    }
+    my $unpack = 1;
+    if ($description eq '.' && $instcodefilter eq '.' && $ownerfilter eq '.' && 
+        $typefilter eq '.') {
+        $unpack = 0;
+    }
+    if (!defined($since)) { $since=0; }
+    my $qresult='';
+
+    my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT())
+        or return "error: ".($!+0)." tie(GDBM) Failed while attempting courseiddump";
+
+	while (my ($key,$value) = each(%$hashref)) {
+            my ($unesc_key,$lasttime_key,$lasttime,$is_hash,%val,
+                %unesc_val,$selfenroll_end,$selfenroll_types,$created,
+                $context);
+            $unesc_key = &unescape($key);
+            if ($unesc_key =~ /^lasttime:/) {
+                next;
+            } else {
+                $lasttime_key = &escape('lasttime:'.$unesc_key);
+            }
+            if ($hashref->{$lasttime_key} ne '') {
+                $lasttime = $hashref->{$lasttime_key};
+                next if ($lasttime<$since);
+            }
+            my ($canclone,$valchange);
+            my $items = &Apache::lonnet::thaw_unescape($value);
+            if (ref($items) eq 'HASH') {
+                if ($hashref->{$lasttime_key} eq '') {
+                    next if ($since > 1);
+                }
+                $is_hash =  1;
+                if ($domcloner) {
+                    $canclone = 1;
+                } elsif (defined($clonerudom)) {
+                    if ($items->{'cloners'}) {
+                        my @cloneable = split(',',$items->{'cloners'});
+                        if (@cloneable) {
+                            if (grep(/^\*$/,@cloneable))  {
+                                $canclone = 1;
+                            } elsif (grep(/^\*:\Q$clonerudom\E$/,@cloneable)) {
+                                $canclone = 1;
+                            } elsif (grep(/^\Q$cloneruname\E:\Q$clonerudom\E$/,@cloneable)) {
+                                $canclone = 1;
+                            }
+                        }
+                        unless ($canclone) {
+                            if ($cloneruname ne '' && $clonerudom ne '') {
+                                if ($cc_clone{$unesc_key}) {
+                                    $canclone = 1;
+                                    $items->{'cloners'} .= ','.$cloneruname.':'.
+                                                           $clonerudom;
+                                    $valchange = 1;
+                                }
+                            }
+                        }
+                    } elsif (defined($cloneruname)) {
+                        if ($cc_clone{$unesc_key}) {
+                            $canclone = 1;
+                            $items->{'cloners'} = $cloneruname.':'.$clonerudom;
+                            $valchange = 1;
+                        }
+                        unless ($canclone) {
+                            if ($items->{'owner'} =~ /:/) {
+                                if ($items->{'owner'} eq $cloner) {
+                                    $canclone = 1;
+                                }
+                            } elsif ($cloner eq $items->{'owner'}.':'.$udom) {
+                                $canclone = 1;
+                            }
+                            if ($canclone) {
+                                $items->{'cloners'} = $cloneruname.':'.$clonerudom;
+                                $valchange = 1;
+                            }
+                        }
+                    }
+                }
+                if ($unpack || !$rtn_as_hash) {
+                    $unesc_val{'descr'} = $items->{'description'};
+                    $unesc_val{'inst_code'} = $items->{'inst_code'};
+                    $unesc_val{'owner'} = $items->{'owner'};
+                    $unesc_val{'type'} = $items->{'type'};
+                    $unesc_val{'cloners'} = $items->{'cloners'};
+                    $unesc_val{'created'} = $items->{'created'};
+                    $unesc_val{'context'} = $items->{'context'};
+                }
+                $selfenroll_types = $items->{'selfenroll_types'};
+                $selfenroll_end = $items->{'selfenroll_end_date'};
+                $created = $items->{'created'};
+                $context = $items->{'context'};
+                if ($selfenrollonly) {
+                    next if (!$selfenroll_types);
+                    if (($selfenroll_end > 0) && ($selfenroll_end <= $now)) {
+                        next;
+                    }
+                }
+                if ($creationcontext ne '.') {
+                    next if (($context ne '') && ($context ne $creationcontext));  
+                }
+                if ($createdbefore > 0) {
+                    next if (($created eq '') || ($created > $createdbefore));   
+                }
+                if ($createdafter > 0) {
+                    next if (($created eq '') || ($created <= $createdafter)); 
+                }
+                if ($catfilter ne '') {
+                    next if ($items->{'categories'} eq '');
+                    my @categories = split('&',$items->{'categories'}); 
+                    next if (@categories == 0);
+                    my @subcats = split('&',$catfilter);
+                    my $matchcat = 0;
+                    foreach my $cat (@categories) {
+                        if (grep(/^\Q$cat\E$/,@subcats)) {
+                            $matchcat = 1;
+                            last;
+                        }
+                    }
+                    next if (!$matchcat);
+                }
+                if ($caller eq 'coursecatalog') {
+                    if ($items->{'hidefromcat'} eq 'yes') {
+                        next if !$showhidden;
+                    }
+                }
+            } else {
+                next if ($catfilter ne '');
+                next if ($selfenrollonly);
+                next if ($createdbefore || $createdafter);
+                next if ($creationcontext ne '.');
+                if ((defined($clonerudom)) && (defined($cloneruname)))  {
+                    if ($cc_clone{$unesc_key}) {
+                        $canclone = 1;
+                        $val{'cloners'} = &escape($cloneruname.':'.$clonerudom);
+                    }
+                }
+                $is_hash =  0;
+                my @courseitems = split(/:/,$value);
+                $lasttime = pop(@courseitems);
+                if ($hashref->{$lasttime_key} eq '') {
+                    next if ($lasttime<$since);
+                }
+	        ($val{'descr'},$val{'inst_code'},$val{'owner'},$val{'type'}) = @courseitems;
+            }
+            if ($cloneonly) {
+               next unless ($canclone);
+            }
+            my $match = 1;
+	    if ($description ne '.') {
+                if (!$is_hash) {
+                    $unesc_val{'descr'} = &unescape($val{'descr'});
+                }
+                if (eval{$unesc_val{'descr'} !~ /\Q$description\E/i}) {
+                    $match = 0;
+                }
+            }
+            if ($instcodefilter ne '.') {
+                if (!$is_hash) {
+                    $unesc_val{'inst_code'} = &unescape($val{'inst_code'});
+                }
+                if ($regexp_ok == 1) {
+                    if (eval{$unesc_val{'inst_code'} !~ /$instcodefilter/}) {
+                        $match = 0;
+                    }
+                } elsif ($regexp_ok == -1) {
+                    if (eval{$unesc_val{'inst_code'} =~ /$instcodefilter/}) {
+                        $match = 0;
+                    }
+                } else {
+                    if (eval{$unesc_val{'inst_code'} !~ /\Q$instcodefilter\E/i}) {
+                        $match = 0;
+                    }
+                }
+	    }
+            if ($ownerfilter ne '.') {
+                if (!$is_hash) {
+                    $unesc_val{'owner'} = &unescape($val{'owner'});
+                }
+                if (($ownerunamefilter ne '') && ($ownerdomfilter ne '')) {
+                    if ($unesc_val{'owner'} =~ /:/) {
+                        if (eval{$unesc_val{'owner'} !~ 
+                             /\Q$ownerunamefilter\E:\Q$ownerdomfilter\E$/i}) {
+                            $match = 0;
+                        } 
+                    } else {
+                        if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E/i}) {
+                            $match = 0;
+                        }
+                    }
+                } elsif ($ownerunamefilter ne '') {
+                    if ($unesc_val{'owner'} =~ /:/) {
+                        if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E:[^:]+$/i}) {
+                             $match = 0;
+                        }
+                    } else {
+                        if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E/i}) {
+                            $match = 0;
+                        }
+                    }
+                } elsif ($ownerdomfilter ne '') {
+                    if ($unesc_val{'owner'} =~ /:/) {
+                        if (eval{$unesc_val{'owner'} !~ /^[^:]+:\Q$ownerdomfilter\E/}) {
+                             $match = 0;
+                        }
+                    } else {
+                        if ($ownerdomfilter ne $udom) {
+                            $match = 0;
+                        }
+                    }
+                }
+            }
+            if ($coursefilter ne '.') {
+                if (eval{$unesc_key !~ /^$udom(_)\Q$coursefilter\E$/}) {
+                    $match = 0;
+                }
+            }
+            if ($typefilter ne '.') {
+                if (!$is_hash) {
+                    $unesc_val{'type'} = &unescape($val{'type'});
+                }
+                if ($unesc_val{'type'} eq '') {
+                    if ($typefilter ne 'Course') {
+                        $match = 0;
+                    }
+                } else {
+                    if (eval{$unesc_val{'type'} !~ /^\Q$typefilter\E$/}) {
+                        $match = 0;
+                    }
+                }
+            }
+            if ($match == 1) {
+                if ($rtn_as_hash) {
+                    if ($is_hash) {
+                        if ($valchange) {
+                            my $newvalue = &Apache::lonnet::freeze_escape($items);
+                            $qresult.=$key.'='.$newvalue.'&';
+                        } else {
+                            $qresult.=$key.'='.$value.'&';
+                        }
+                    } else {
+                        my %rtnhash = ( 'description' => &unescape($val{'descr'}),
+                                        'inst_code' => &unescape($val{'inst_code'}),
+                                        'owner'     => &unescape($val{'owner'}),
+                                        'type'      => &unescape($val{'type'}),
+                                        'cloners'   => &unescape($val{'cloners'}),
+                                      );
+                        my $items = &Apache::lonnet::freeze_escape(\%rtnhash);
+                        $qresult.=$key.'='.$items.'&';
+                    }
+                } else {
+                    if ($is_hash) {
+                        $qresult .= $key.'='.&escape($unesc_val{'descr'}).':'.
+                                    &escape($unesc_val{'inst_code'}).':'.
+                                    &escape($unesc_val{'owner'}).'&';
+                    } else {
+                        $qresult .= $key.'='.$val{'descr'}.':'.$val{'inst_code'}.
+                                    ':'.$val{'owner'}.'&';
+                    }
+                }
+            }
+	}
+    &untie_domain_hash($hashref) or 
+        return "error: ".($!+0)." untie(GDBM) Failed while attempting courseiddump";
+
+    chop($qresult);
+    return $qresult;
+}
+
+sub dump_profile_database {
+    my ($tail) = @_;
+
+    my ($udom,$uname,$namespace) = split(/:/,$tail);
+
+    my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_READER()) or
+        return "error: ".($!+0)." tie(GDBM) Failed while attempting currentdump";
+
+	# Structure of %data:
+	# $data{$symb}->{$parameter}=$value;
+	# $data{$symb}->{'v.'.$parameter}=$version;
+	# since $parameter will be unescaped, we do not
+ 	# have to worry about silly parameter names...
+	
+        my $qresult='';
+	my %data = ();                     # A hash of anonymous hashes..
+	while (my ($key,$value) = each(%$hashref)) {
+	    my ($v,$symb,$param) = split(/:/,$key);
+	    next if ($v eq 'version' || $symb eq 'keys');
+	    next if (exists($data{$symb}) && 
+		     exists($data{$symb}->{$param}) &&
+		     $data{$symb}->{'v.'.$param} > $v);
+	    $data{$symb}->{$param}=$value;
+	    $data{$symb}->{'v.'.$param}=$v;
+	}
+
+    &untie_user_hash($hashref) or
+        return "error: ".($!+0)." untie(GDBM) Failed while attempting currentdump";
+
+    while (my ($symb,$param_hash) = each(%data)) {
+    while(my ($param,$value) = each (%$param_hash)){
+        next if ($param =~ /^v\./);       # Ignore versions...
+        #
+        #   Just dump the symb=value pairs separated by &
+        #
+        $qresult.=$symb.':'.$param.'='.$value.'&';
+    }
+    }
 
+    chop($qresult);
+    return $qresult;
+}
 
 
 1;
@@ -387,6 +776,13 @@ Returns: 1 (Continue processing).
 
 Side effects: response is written to $client.  
 
+=item dump_couse_id_handler
+
+#TODO copy from lond
+
+=item dump_profile_database
+
+#TODO copy from lond  
 
 =item releasereqd_check( $cnum, $cdom, $key, $value, $major, $minor, 
         $homecourses, $ids )