Index: /main/trunk/greenstone2/perllib/cgiactions/docextractaction.pm
===================================================================
--- /main/trunk/greenstone2/perllib/cgiactions/docextractaction.pm	(revision 28248)
+++ /main/trunk/greenstone2/perllib/cgiactions/docextractaction.pm	(revision 28249)
@@ -46,5 +46,5 @@
 	"extract-archives-doc" => { # where param can be ONE of: index (default), import, archives, live
 	    'compulsory-args' => [ "d", "json-sections" ],
-	    'optional-args'   => [ "json-metadata" ],
+	    'optional-args'   => [ "json-metadata", "newd" ],
 #	    'optional-args'   => [ "where" ],
 	    'help-string' => [
@@ -78,4 +78,259 @@
 
 
+
+sub dxml_start_section
+{
+    my ($tagname, $attrHash, $contextArray, $parentDataArray, $parser) = @_;
+
+    my $new_depth = scalar(@$contextArray);
+
+    if ($new_depth == 1) {
+	$parser->{'parameters'}->{'curr_section_depth'} = 1;
+	$parser->{'parameters'}->{'curr_section_num'}   = "";
+    }
+
+    my $old_depth  = $parser->{'parameters'}->{'curr_section_depth'};
+    my $old_secnum = $parser->{'parameters'}->{'curr_section_num'};
+
+    my $new_secnum;
+
+    if ($new_depth > $old_depth) {
+	# child subsection
+	$new_secnum = "$old_secnum.1";
+    }
+    elsif ($new_depth == $old_depth) {
+	# sibling section => increase it's value by 1
+	my ($tail_num) = ($old_secnum =~ m/\.(\d+)$/);
+	$tail_num++;
+	$new_secnum = $old_secnum;
+	$new_secnum =~ s/\.(\d+)$/\.$tail_num/;
+    }
+    else {
+	# back up to parent section => lopp off tail
+###	print STDERR "**### back up to parent section, $old_secnum = $old_secnum\n";
+
+	$new_secnum = $old_secnum;
+	$new_secnum =~ s/\.\d+$//;
+    }
+
+    $parser->{'parameters'}->{'curr_section_depth'} = $new_depth;
+    $parser->{'parameters'}->{'curr_section_num'}   = $new_secnum;
+	
+    1;
+}
+
+
+sub dxml_section
+{
+	my ($tagname, $attrHash, $contextArray, $parentDataArray, $parser) = @_;
+
+	my $sec_num_hash = $parser->{'parameters'}->{'sec_num_hash'};
+	my $curr_sec_num = $parser->{'parameters'}->{'curr_section_num'} || undef;
+
+	my $mode = $parser->{'parameters'}->{'mode'};
+
+	my $depth = $parser->{'parameters'}->{'curr_section_depth'};
+
+	my $live_depth = scalar(@$contextArray);
+
+#	print STDERR "closing secdtion tag, mode: $mode, curr sec num = $curr_sec_num, live depth = $live_depth\n";
+
+	if ($live_depth == 1) {
+	    # root sectin tag, which must always exist
+#	    print STDERR "*** root, tagname = $tagname, attrHash = $attrHash ", 
+#	      " '_content' = ", join(",",@{$attrHash->{'_content'}}), "\n";
+	    return [$tagname => $attrHash];
+	}
+	elsif (defined $sec_num_hash->{$curr_sec_num}) {
+###	    print STDERR "*** got a match on $curr_sec_num, mode = $mode\n";
+
+	    if ($mode eq "extract") {
+		# keep it
+		return [$tagname => $attrHash];
+	    }
+	    else {
+		# remove
+		return undef;
+	    }
+	}
+	else {
+	    # not in our list
+	    if ($mode eq "extract") {
+		# remove
+		return undef;
+	    }
+	    else {
+		# keep it
+		return [$tagname => $attrHash];
+	    }
+	}
+}
+
+
+sub remove_from_doc_xml
+{
+	my $self = shift @_;
+	my ($gsdl_cgi, $doc_xml_filename, $newdoc_xml_filename, $sec_num_hash, $mode) = @_;
+	
+	my @start_rules = ('Section' => \&dxml_start_section);
+	
+	# Set the call-back functions for the metadata tags
+	my @rules = 
+	( 
+		_default => 'raw',
+		'Section' => \&dxml_section
+	);
+	    
+	my $parser = XML::Rules->new
+	(
+		start_rules => \@start_rules,
+		rules => \@rules, 
+		style => 'filter',
+		output_encoding => 'utf8',
+##	 normalisespaces => 1, # http://search.cpan.org/~jenda/XML-Rules-1.16/lib/XML/Rules.pm
+#	 	stripspaces => 2|0|0 # ineffectual
+	);
+	
+	my $status = 0;
+	my $xml_in = "";
+	if (!open(MIN,"<$doc_xml_filename")) 
+	{
+		$gsdl_cgi->generate_error("Unable to read in $doc_xml_filename: $!");
+		$status = 1;
+	}
+	else 
+	{
+		# Read them in
+		my $line;
+		while (defined ($line=<MIN>)) {
+			$xml_in .= $line;
+		}
+		close(MIN);	
+
+		# Filter with the call-back functions
+		my $xml_out = "";
+
+		my $MOUT;
+		if (!open($MOUT,">$newdoc_xml_filename")) {
+			$gsdl_cgi->generate_error("Unable to write out to $newdoc_xml_filename: $!");
+			$status = 1;
+		}
+		else {
+			binmode($MOUT,":utf8");
+
+			my $options = {sec_num_hash => $sec_num_hash, mode => $mode };
+
+			$parser->filter($xml_in, $MOUT, $options);
+			close($MOUT);	    
+		}
+	}
+	return $status;
+}
+
+sub sections_as_hash
+{
+    my $self = shift @_;
+
+    my ($json_sections_array,$mode) = @_;
+
+    my $sec_num_hash = {};
+
+    foreach my $sn ( @$json_sections_array ) {
+
+	# our XML parser curr_sec_num puts '.' at the root
+	# Need to do the same here, so things can be matched up
+	$sec_num_hash->{".$sn"} = 1; 
+
+###	print STDERR "** storeing .$sn\n";
+
+	if ($mode eq "with-parents") {
+	    my $sn_copy = $sn; # needs to be a copy, otherwise chaning version stored in json_sections
+	    while ($sn_copy =~ s/\.\d+$//) {
+		$sec_num_hash->{".$sn_copy"} = 1; # See '.' comment above
+
+####		print STDERR "** ***** parent storeing .$sn_copy\n";
+	    }
+	}
+    }
+
+    return $sec_num_hash;
+}
+
+
+
+sub _extract_archives_doc
+{
+	my $self = shift @_;
+
+	my $collect   = $self->{'collect'};
+	my $gsdl_cgi  = $self->{'gsdl_cgi'};
+	my $infodbtype = $self->{'infodbtype'};
+	
+	my $site = $self->{'site'};
+		
+	# Obtain the collect and archive dir   
+	my $collect_dir = $gsdl_cgi->get_collection_dir($site);	
+	
+	my $archive_dir = &util::filename_cat($collect_dir,$collect,"archives");
+
+	# look up additional args
+	my $docid = $self->{'d'};
+	my $new_docid = $self->{'newd'} || "HASH" . localtime(time);
+
+	my $json_sections_str = $self->{'json-sections'};
+	my $json_sections_array = decode_json($json_sections_str);
+
+
+	my $arcinfo_doc_filename = &dbutil::get_infodb_file_path($infodbtype, "archiveinf-doc", $archive_dir);
+	my $doc_rec = &dbutil::read_infodb_entry($infodbtype, $arcinfo_doc_filename, $docid);
+
+	my $doc_file = $doc_rec->{'doc-file'}->[0];	
+	my $doc_filename = &util::filename_cat($archive_dir, $doc_file);
+
+	my $newdoc_filename = &util::filename_cat($archive_dir, "test.xml");
+
+#	# This now stores the full pathname
+#	my $doc_filename = $doc_rec->{'doc-file'}->[0];	
+
+	my $extract_sec_num_hash = $self->sections_as_hash($json_sections_array,"with-parents");
+
+	my $extract_status = $self->remove_from_doc_xml($gsdl_cgi, $doc_filename ,$newdoc_filename, $extract_sec_num_hash, "extract");
+	
+	if ($extract_status == 0) 
+	{
+	    my $delete_sec_num_hash = $self->sections_as_hash($json_sections_array,"no-parents");
+
+	    my $delete_status = $self->remove_from_doc_xml($gsdl_cgi, $doc_filename ,$doc_filename, $delete_sec_num_hash, "delete");
+
+	    if ($delete_status == 0) {
+
+		my $mess = "document-extract successful: Key[$docid]\n";
+
+		$gsdl_cgi->generate_ok_message($mess);	
+	    }
+	    else {
+		my $mess .= "Failed to extract identified section numbers for key: $docid\n";
+		$mess .= "Exit status: $delete_status\n";
+		$mess .= "System Error Message: $!\n";
+		$mess .= "-" x 20 . "\n";
+		
+		$gsdl_cgi->generate_error($mess);
+	    }
+	}
+	else 
+	{
+		my $mess .= "Failed to remove identified section numbers for key: $docid\n";
+		$mess .= "Exit status: $extract_status\n";
+		$mess .= "System Error Message: $!\n";
+		$mess .= "-" x 20 . "\n";
+		
+		$gsdl_cgi->generate_error($mess);
+	}
+	
+	#return $status; # in case calling functions have a use for this
+}
+
+
+
 # JSON version that will get the requested metadata values 
 # from the requested source (index, import, archives or live)
@@ -84,27 +339,25 @@
 sub extract_archives_doc
 {
-    my $self = shift @_;
-
-#    my $where = $self->{'where'};
-#    if (!$where) {	
-#	$where = "index"; # default behaviour is to get the values from index
-#    }
-
-    # Only when setting metadata do we perform authentication and do we lock the collection,
-    # not when getting metadata
-
-    # for get_meta_array, the where param can only be ONE of import, archives, index, live
-#    if($where =~ m/index/) {
-#	$self->_get_index_metadata_array(@_);
-#    }
-#    elsif($where =~ m/archives/) {
-#	$self->_get_archives_metadata_array(@_);
-#    }
-#    elsif($where =~ m/import/) {
-#	$self->_get_import_metadata_array(@_);
-#    }
-#    elsif($where =~ m/live/) {
-#    	$self->_get_live_metadata_array(@_);
-#    }
+	my $self = shift @_;
+
+	my $username  = $self->{'username'};
+	my $collect   = $self->{'collect'};
+	my $gsdl_cgi  = $self->{'gsdl_cgi'};
+	
+	if ($baseaction::authentication_enabled) 
+	{
+	    # Ensure the user is allowed to edit this collection		
+	    $self->authenticate_user($username, $collect); 
+	}
+
+	# Make sure the collection isn't locked by someone else
+	$self->lock_collection($username, $collect);
+
+	$self->_extract_archives_doc(@_);
+
+	# Release the lock once it is done
+	$self->unlock_collection($username, $collect);
+
+
 }
 
