#!/usr/local/bin/perl -w 
# -*- perl -*-
######################################################################
# remove-object.pl -- Remove object from given gff file
# Copyright (c) 2008 Tero Kivinen
# All Rights Reserved.
######################################################################
#         Program: remove-object.pl
#	  $Source: /u/samba/nwn/bin/RCS/remove-object.pl,v $
#	  Author : $Author: kivinen $
#
#	  (C) Tero Kivinen 2008 <kivinen@iki.fi>
#
#	  Creation          : 22:29 Mar 25 2008 kivinen
#	  Last Modification : 00:27 Mar 26 2008 kivinen
#	  Last check in     : $Date: 2008/03/25 22:29:58 $
#	  Revision number   : $Revision: 1.1 $
#	  State             : $State: Exp $
#	  Version	    : 1.67
#	  Edit time	    : 48 min
#
#	  Description       : Remove object from given gff file
#
#	  $Log: remove-object.pl,v $
#	  Revision 1.1  2008/03/25 22:29:58  kivinen
#	  	Created.
#
#	  $EndLog$
#
#
#
#
######################################################################
# initialization

require 5.6.0;
package RemoveObject;
use strict;
use Getopt::Long;
use File::Glob ':glob';
use Gff;
use GffRead;
use GffWrite;
use Time::HiRes qw(time);
use Pod::Usage;

$Opt::verbose = 0;
@Opt::objects_to_remove = ();
%Opt::resrefs_to_remove = ();
%Opt::tags_to_remove = ();
$Opt::no_write = 0;
$Opt::backup = 0;

######################################################################
# Get version information

open(PROGRAM, "<$0") || die "Cannot open myself from $0 : $!";
undef $/;
$Prog::program = <PROGRAM>;
$/ = "\n";
close(PROGRAM);
if ($Prog::program =~ /\$revision:\s*([\d.]*)\s*\$/i) {
    $Prog::revision = $1;
} else {
    $Prog::revision = "?.?";
}

if ($Prog::program =~ /version\s*:\s*([\d.]*\.)*([\d]*)\s/mi) {
    $Prog::save_version = $2;
} else {
    $Prog::save_version = "??";
}

if ($Prog::program =~ /edit\s*time\s*:\s*([\d]*)\s*min\s*$/mi) {
    $Prog::edit_time = $1;
} else {
    $Prog::edit_time = "??";
}

$Prog::version = "$Prog::revision.$Prog::save_version.$Prog::edit_time";
$Prog::progname = $0;
$Prog::progname =~ s/^.*[\/\\]//g;

$| = 1;

######################################################################
# Read rc-file

if (defined($ENV{'HOME'})) {
    read_rc_file("$ENV{'HOME'}/.removeobjectrc");
}

######################################################################
# Option handling

Getopt::Long::Configure("no_ignore_case");

if (!GetOptions("config=s" => \$Opt::config,
		"verbose|v+" => \$Opt::verbose,
		"help|h" => \$Opt::help,
		"no-write|n" => \$Opt::no_write, 
		"backup|b" => \$Opt::backup,
		"tag|t=s" => sub {
		    my($name, $value) = @_;
		    $Opt::tags_to_remove{$value} = 1;
		},
		"resref|r=s" => sub {
		    my($name, $value) = @_;
		    $Opt::resrefs_to_remove{$value} = 1;
		},
		"object|o=s" => sub {
		    my($name, $value) = @_;
		    push(@Opt::objects_to_remove, $value);
		},
		"version|V" => \$Opt::version) || defined($Opt::help)) {
    usage();
}

if (defined($Opt::version)) {
    print("\u$Prog::progname version " .
	  "$Prog::version by Tero Kivinen.\n");
    exit(0);
}

while (defined($Opt::config)) {
    my($tmp);
    $tmp = $Opt::config;
    undef $Opt::config;
    if (-f $tmp) {
	read_rc_file($tmp);
    } else {
	die "Config file $Opt::config not found: $!";
    }
}

######################################################################
# Main loop

$| = 1;

my($i, $t0);

if (join(";", @ARGV) =~ /[*?]/) {
    my(@argv);
    foreach $i (@ARGV) {
	push(@argv, bsd_glob($i));
    }
    @ARGV = @argv;
}

foreach $i (@ARGV) {
    my($gff);
    $t0 = time();
    if ($Opt::verbose > 1) {
	print("Reading file $i...\n");
    }
    $main::file = $i;
    $gff = GffRead::read(filename => $i);
    if ($Opt::verbose > 2) {
	printf("Read done, %g seconds\n", time() - $t0);
    }
    $main::modified = 0;
    $gff->find(find_label => '\]/$', # '
	       proc => \&find_proc);
    if (!$Opt::no_write) {
	if ($main::modified) {
	    if ($Opt::backup) {
		if ($Opt::verbose > 1) {
		    print("Renaming $i -> $i.bak...\n");
		}
		rename($i, $i . ".bak");
	    }
	    if ($Opt::verbose) {
		print("Writing file $i...\n");
	    }
	    remove_undefs($gff);
	    &GffWrite::write($gff, filename => $i);
	} else {
	    if ($Opt::verbose) {
		print("Skipped unmodified file $i...\n");
	    }
	}
    }
}

exit 0;

######################################################################
# Find proc
sub find_proc {
    my($gff, $full_label, $label, $value, $parent_gffs) = @_;
    my($res, $tag, $i, $do_remove, $parent_gff);
    $res = $$gff{TemplateResRef};
    $tag = $$gff{Tag};
    $do_remove = 0;
    foreach $i (@Opt::objects_to_remove) {
	if ($full_label =~ /$i/) {
	    $do_remove = 1;
	}
    }
    if ((defined($res) && defined($Opt::resrefs_to_remove{$res})) ||
	(defined($tag) && defined($Opt::tags_to_remove{$tag})) ||
	$do_remove) {
	if ($full_label =~ /\/([^\/]*)\[(\d+)\]\/$/) {
	    $parent_gff = $$parent_gffs[-2];
	    $$parent_gff{$1}[$2] = undef;
	    if ($Opt::verbose) {
		print("Removing $main::file: $full_label\n");
		$main::modified = 1;
	    }
	}
    }
    return;
}

######################################################################
# remove_undefs($gff);

sub remove_undefs {
    my($self) = @_;
    
    foreach $i (keys %{$self}) {
	next if ($i =~ /____((struct_|file_|)type|file_version)$/);
	next if ($i eq '');
	if (UNIVERSAL::isa($$self{$i}, 'ARRAY')) {
	    my($item, $j, $array);
	    $array = $$self{$i};
	    for($j = $#{$array}; $j >= 0; $j--) {
		$item = $$array[$j];
		if (!defined($item)) {
		    splice(@$array, $j, 1);
		} else {
		    remove_undefs(Gff->new($item));
		}
	    }
	} elsif (UNIVERSAL::isa($$self{$i}, 'HASH')) {
	    remove_undefs(Gff->new($$self{$i}));
	} elsif (!defined($$self{$i})) {
	    delete $$self{$i};
	}
    }
}

######################################################################
# Read rc file

sub read_rc_file {
    my($file) = @_;
    my($next, $space);
    
    if (open(RCFILE, "<$file")) {
	while (<RCFILE>) {
	    chomp;
	    while (/\\$/) {
		$space = 0;
		if (/\s+\\$/) {
		    $space = 1;
		}
		s/\s*\\$//g;
		$next = <RCFILE>;
		chomp $next;
		if ($next =~ s/^\s+//g) {
		    $space = 1;
		}
		if ($space) {
		    $_ .= " " . $next;
		} else {
		    $_ .= $next;
		}
	    }
	    if (/^\s*([a-zA-Z0-9_]+)\s*$/) {
		eval('$Opt::' . lc($1) . ' = 1;');
	    } elsif (/^\s*([a-zA-Z0-9_]+)\s*=\s*\"([^\"]*)\"\s*$/) {
		my($key, $value) = ($1, $2);
		$value =~ s/\\n/\n/g;
		$value =~ s/\\t/\t/g;
		eval('$Opt::' . lc($key) . ' = $value;');
	    } elsif (/^\s*([a-zA-Z0-9_]+)\s*=\s*(.*)\s*$/) {
		my($key, $value) = ($1, $2);
		$value =~ s/\\n/\n/g;
		$value =~ s/\\t/\t/g;
		eval('$Opt::' . lc($key) . ' = $value;');
	    }
	}
	close(RCFILE);
    }
}

######################################################################
# Usage

sub usage {
    Pod::Usage::pod2usage(0);
}

=head1 NAME

remove-object - Remove objects from file

=head1 SYNOPSIS

remove-object [B<--help>|B<-h>] [B<--version>|B<-V>] [B<--verbose>|B<-v>]
    [B<--config> I<config-file>]
    [B<--no-write>|B<-n>]
    [B<--backup>|B<-b>]
    [B<--resref>|B<-r> I<resref-to-remove>]
    [B<--tag>|B<-t> I<tag-to-remove>]
    [B<--object>|B<-o> I<regexp-of-labels-to-remove>]
    I<filename> ...

remove-object B<--help>

=head1 DESCRIPTION

B<remove-object> removes the objects in the file that has
TemplateResRef matching any of the B<--resref> options or which has
Tag matching any of the B<--tag> options given. You can also give list
of regexps in B<--object> option and any object whose full label
matches that is removed.

=head1 OPTIONS

=over 4

=item B<--help> B<-h>

Prints out the usage information.

=item B<--version> B<-V>

Prints out the version information. 

=item B<--verbose> B<-v>

Enables the verbose prints. This option can be given multiple times,
and each time it enables more verbose prints. 

=item B<--config> I<config-file>

All options given by the command line can also be given in the
configuration file. This option is used to read another configuration
file in addition to the default configuration file. 

=item B<--no-write> B<-n>

Do not write anything, but do the modifications etc. This can be used
to check that everything is modified properly before actually doing
the modification.

=item B<--backup> B<-b>

Take backup copy of the file before writing it back. The backup copy
will be named F<file.git.bak>.

=item B<--tag> B<-t> I<tag-to-remove>

If the object is having exactly the tag given then it is removed.

=item B<--resref> B<-r> I<resref-to-remove>

If the object is having exactly the TemplateResRef given then it is
removed.

=item B<--object> B<-f> I<regexp-of-labels-to-remove>

If the object has full label matching the regexps given here they are
removed.

=head1 FILES

=over 6

=item ~/.removeobjectrc

Default configuration file.

=back

=head1 SEE ALSO

gffencode(1), gffmatch(1), gffmodify(1), gffprint(1), Gff(3),
GffWrite(3) and GffRead(3).

=head1 AUTHOR

Tero Kivinen <kivinen@iki.fi>.

=head1 HISTORY

This program evolved from gffmodify(1) to allow easy removal of
objects.