#! /usr/bin/perl -w
#
# Copyright (c) 2011-2013 by Cisco Systems, Inc.
# All rights reserved
#

=pod

=head1 NAME

image-tool - imaging building tool for Roc build environment.

=head1 SYNOPSIS

image-tool [ I<options> ] [ I<file> ]

=head1 DESCRIPTION

Allows creating archive with devices and arbitrary file ownership.  A manifest
is read from stdin or the specified <file> and a tar archive is written to
stdout.  The manifest is a list of simple rules to copy files from the normal
filesystem storage, or to copy files from other archives, or to make special
files.  File ownership and mode can also be set.

=head1 OPTIONS

=over 4

=item B<--deps>, B<--dependencies>

Instead writing an archive, just list all the files that would be
referenced to make the archive. (Note that where wildcard patterns are used,
the wildcard patterns are not resolved, and just printed as is).

=item B<--tmp>=I<dir>

Use I<dir> to create temporary files (only needed when copying regular
files from other archives).

=item B<-C> I<dir>, B<--start-dir>=I<dir>

Change directory to I<dir> before processing the manifest.

=item B<-o> -I<file>, B<--output>=I<file>

Set the output file.

=back

=head1 IMAGE FILE FORMAT

=over 4

=item B<output> I<target-file>

Name of the output archive.  The command used to create the archive will be
determined from the archive name.  E.g I<xxxx>.cpio.gz will be a gzipped cpio
archive from B<pax> piped through B<gzip> or I<xxxx>.iso would be an iso image
from I<mkisofs>.  System install images use the ".ii" extension.
Unit test images will use the ".ut" extension.

=item B<outflags> I<options>...

Arguments to pass to the archive program.

=item B<copy> [ mode=I<mode> ] [ owner=I<user>:I<group> ] I<src-file>... I<dest-file>

Insert I<src-file> in the archive as I<dest-file>.

=item B<copy> [ -l ] [ mode=I<mode> ] [ owner=I<user>:I<group> ] I<src-file>... I<dest-dir>/

Insert the I<src-file>s into the archive changing the path, but
leaving the simple name unchanged.  With -l copy the any link
target instead of just the link.

=item B<from> I<archive>

Set the location for I<src-file>s to be the specified archive.
Tar, cpio, debian and rpm archives are supported.
Set's CD to / (the root of the archive).

=item B<from> I<directory>/

Set the location for I<src-file>s from the host filesystem, relative
to I<directory>.  The trailing / is required.

=item B<cd>

Set a prefix directory on files from I<src-files>s from the current archive.

=item B<ignore> I<file>...

In an archive, act as if the specified files are not present.

=item B<symlink> [ mode=I<mode> | owner=I<user>:I<group> ] I<link-contents> I<dest-file>...

Make a symbolic link.  The default mode of the link is 0777.

=item B<hardlink> [ mode=I<mode> | owner=I<user>:I<group> ] I<old-file> I<dest-file>...

Make a hard link. I<old-file> must be name in the archive of a regular
file already inserted.

=item B<device> [ mode=I<mode> | owner=I<user>:I<group> ] [b|c] I<major>,I<minor> I<dest-file>

Create a block or character device in the archive.

=item B<directory> [ mode=I<mode> | owner=I<user>:I<group> ] I<dirname>...

Create directories in the archive.

=item B<rpm> I<prefix> I<rpm-file>...

Install complete contents of listed rpms, although the B<ignore> command can
be used to trim out some of the contents.

=item B<opkg> [ I<opkg-file> | --<opkg-option> ]...

Install complete contents of listed debian packages, although the B<ignore>
command can be used to trim out some of the contents.

=item B<ids> I<user-file> I<group-file>

Get user name <=> uid mapping info from I<user-file> and group name <=> gid
mapping info from I<group-file> nstead of /etc/passwd and /etc/group.  Must
appear before first B<from> commmand.

=item B<ii> B<release> I<version-text>

Set the system install image release version information.

=item B<ii> B<models> I<model>...

Define the list of valid names that can be used in the models command.

=item B<ii> B<type> I<type>

Set the install image type: B<full>, B<transient>, B<incremental>, B<patch>.

=item B<models> I<model>...

In a system install image, set which model types for the following files will
be installed on.  Remains in effect until another B<models> command is used.

=item B<include> I<file>

Process commands from the given file.

=item B<perl> I<perl-expression>

Evaluate the I<perl-expression>.  This can be used to set scalar variables
that are expanded in the commands above via $I<varname> or $I<{varname>}.

=item B<if> I<perl-expression>

=item I<command-block->1

=item [ B<elif> I<perl-expression>

=item B<>  I<command-block->2..n  ] ...

=item [ B<else>

=item B<>  I<command-block->n+1 ]

=item B<endif>

Conditional processing - evaluate at most one block of intervening commands
between the B<if> and B<endif>. Truth is according to perl rules, so undefined
values, 0, empty strings, empty arrays, are "false".

=item B<final_action> I<bash-command>

Extra processing to be performed on image directory, which will be named
$IMAGE_DIR.  This should not reference any files outside the image directory
since the they wouldn't be captured as part of the dependency tree.


=back

=cut
#use strict;
use File::Basename qw(dirname basename fileparse);
use Cwd;

my $need_rm = 0;
my $errors = 0;

my %u_id_name;
my %u_name_id;
my %g_id_name;
my %g_name_id;

my $default_uid = 1000;
my $default_gid = 1000;

my $my_uid = $<;
my $my_uname = $ENV{USER};

my @final_actions;

chomp(my $my_gid = `id -g`);
chomp(my $my_gname = `id -ng`);

$u_name_id{$my_uname} = $default_uid;
$g_name_id{$my_gname} = $default_gid;


my $mode_add = 0;
my $mode_set = 0;
my $mode_sub = 0;
my $debug = 0;
my $out_fmt = "";
my $out_compress = "";
my $out_options = "";

my $dependencies_only = 0;
my $in_ova = 0;

my $in_ii = 0;
my %ii_files_for_model;
my $ii_models_set;
my %ii_data = (models => "", release => "", type => "");
my %ii_types = (full => 0, incremental => 0, transient => 0, patch => 0);
my @ii_models;

my $out_file;
my $out_file_name;
my $log_file_name;
my @deps;

sub dmp($) {
    my $dct = shift;
    # for debugging...
    my @k = sort keys %$dct;
    for my $k (@k) {
	my $v = $dct->{$k};
	my $t = $v->{FILE_TYPE};
	print STDERR "$k: $t ", join(':', @{$v->{OWNER}}),
	" ", mode_txt($v->{MODE});
	if ($t eq 'F') {
	    print STDERR " disk=$v->{DISK_FILE}" if $v->{DISK_FILE};
	} elsif ($t eq 'C' || $t eq 'B') {
	    print STDERR ($v->{DEVICE_NUM}>>8), ",", $v->{DEVICE_NUM} & 255;
	} elsif ($t eq 'S' or $t eq 'H' ) {
	    print STDERR " link=$v->{LINK}";
	}
	print STDERR "\n";
    }
}

sub own_adj {
    my ($u, $g, $unk_ok) = @_;
    if ($u !~ /^\d+$/) {
	if (!defined($u_name_id{$u})) {
	    $u_name_id{$u} = $default_uid;
	    Warn("Don't know user $u\n") unless $unk_ok;
	}
	$u = $u_name_id{$u}
    }
    if ($g !~ /^\d+$/) {
	if (!defined($g_name_id{$g})) {
	    $g_name_id{$g} = $default_gid;
	    Warn("Don't know group $g\n") unless $unk_ok;
	}
	$g = $g_name_id{$g}
    }
    return [$u, $g];
}

sub setup_uid_gid_dicts($$)
{
    my ($uid_f, $gid_f) = @_;
    my $fh;
    open($fh, "<", $uid_f) or Die("$!: $uid_f\n");
    while (<$fh>) {
	my @F = split /:/;
	next if $#F < 2;
	$u_id_name{$F[2]} = $F[0];
	$u_name_id{$F[0]} = $F[2];
    }
    close($fh);
    open($fh, "<", $gid_f) or Die("$!: $gid_f\n");
    while (<$fh>) {
	my @F = split /:/;
	next if $#F < 2;
	$g_id_name{$F[2]} = $F[0];
	$g_name_id{$F[0]} = $F[2];
    }
    close($fh);
}

# stack of [ file-handle, file-name, line-number ]
my @source_stack;

sub Warn {
    my $msg = "@_";
    chomp $msg;
    print STDERR "$source_stack[0][1]: $source_stack[0][2]: " if @source_stack;
    print STDERR "$msg\n";
}
sub Err { Warn @_; $errors++; }
sub Die { Err @_; exit 1; }

sub mode_val {
    my $ms = shift;
    my $mv = 0;
    $mv |= 0x100 if substr($ms, 0, 1) eq 'r';
    $mv |= 0x080 if substr($ms, 1, 1) eq 'w';
    $mv |= 0x840 if substr($ms, 2, 1) eq 's';
    $mv |= 0x040 if substr($ms, 2, 1) eq 'x';
    $mv |= 0x020 if substr($ms, 3, 1) eq 'r';
    $mv |= 0x010 if substr($ms, 4, 1) eq 'w';
    $mv |= 0x408 if substr($ms, 5, 1) eq 's';
    $mv |= 0x008 if substr($ms, 5, 1) eq 'x';
    $mv |= 0x004 if substr($ms, 6, 1) eq 'r';
    $mv |= 0x002 if substr($ms, 7, 1) eq 'w';
    $mv |= 0x001 if substr($ms, 8, 1) eq 'x';
    return $mv;
}

sub mode_txt {
    my $m = shift;
    return ((($m & 0x0100) ? 'r' : '-').
	    (($m & 0x0080) ? 'w' : '-').
	    (($m & 0x0800) ? 's' : (($m & 0x0040) ? 'x' : '-')).
	    (($m & 0x0020) ? 'r' : '-').
	    (($m & 0x0010) ? 'w' : '-').
	    (($m & 0x0400) ? 's' : (($m & 0x0008) ? 'x' : '-')).
	    (($m & 0x0004) ? 'r' : '-').
	    (($m & 0x0002) ? 'w' : '-').
	    (($m & 0x0001) ? 'x' : '-'));
}


# if file type is a number, it means the value is the archive name holding the
# regular file or hard link We can't tell until the files we want from it are
# unpacked.
my %file_type = (
    'F' => 0, #regular file
    'H' => 1, #hard link
    'S' => 2, #symbolic link
    'C' => 3, #char dev
    'B' => 4, #block dev
    'D' => 5, #directory
    'P' => 6, #fifo
    'O' => 8, #socket
    );

chomp(my $orig_pwd = `pwd`);
my $pwd = '.';
my $tmp_dir = "$orig_pwd/.image_tmp$$";
my %fd;

sub fix_tgt {
    # tar doesn't want archives file names to start with /
    # so we'll strip it to be consistent, and let's go ahead and make it
    # canonical anyway..
    my $t = shift;
    my @tgt = split '/', $t;
    my @res;
    for my $t (@tgt) {
	if ($t eq '..') {
	    pop @res if @res;
	} elsif ($t && ($t ne '.')) {
	    push @res, $t;
	}
    }
    return join "/", @res;
}


sub fix_tgt_maybe_dir {
    my $t = shift;
    my $res = fix_tgt($t);
    $res .= '/' if $res and $t =~ /\/\.?\.?$/;
    return $res;
}

sub add_f ($$) {
    my ($file, $dct) = @_;
    Err("Name too long $file") if length($file) > 100;
    $dct->{SRC_LINE} = "$source_stack[0][1]: $source_stack[0][2]";
    $file = fix_tgt($file);
    if ($in_ii) {
	if ($dct->{FILE_TYPE} =~ /[HF]/) {
	    if (!@ii_models) {
		Err("Missing 'models' list.") unless $ii_models_set++;
		return;
	    }
	    for (@ii_models) {
		push @{$ii_files_for_model{$_}}, $file;
	    }
	} elsif ($dct->{FILE_TYPE} ne 'D') {
	    Err("Only files and dirs allowed in system image\n");
	}
    }
    if (defined($fd{$file})) {
	if ($fd{$file}{FILE_TYPE}.$dct->{FILE_TYPE} ne 'DD') {
	    my $ln = $fd{$file}{SRC_LINE};
	    Err("Already have $file in archive (from $ln)\n");
	}
	return;
    }
    $fd{$file} = $dct;
    if ($dct->{FILE_TYPE} eq 'H') {
	# We will write archive in sorted order,
	# make sure if two files are hard linked to each other
	# the first one will have the contents.
	my $other_file = $dct->{LINK};
	if ($file lt $other_file) {
	    $dct->{DISK_FILE} = $fd{$other_file}{DISK_FILE};
	    $dct->{FILE_TYPE} = 'F';
	    $dct->{SIZE} = $fd{$other_file}{SIZE};
	    $fd{$other_file}{FILE_TYPE} = 'H';
	    $fd{$other_file}{LINK} = $file;
	    Warn("DEBUG: changing $file to be H to $other_file\n") if $debug;
	}
    }
    Warn("DEBUG: adding $file as $dct->{FILE_TYPE}") if $debug;
}

sub abs_path($) {
    my $path = shift;
    $path = "$pwd/$path" if $pwd && $path !~ /^\//;
    $path =~ s,$orig_pwd/,,;
    $path = fix_tgt($path) if $path !~ /^\//;
    return $path;
}

my $ar_cd = "";
sub ar_path($) {
    my $path = shift;
    $path = "$ar_cd/$path" if $path !~ /^\//;
    return fix_tgt($path);
}

sub make_dest($$) {
    my ($dest, $src) = @_;
    if (!$dest || $dest =~ /\/$/) {
	$src =~ s/\/+$//;
	$src =~ s,.*/,,;
	$dest .= $src;
    }
    return $dest;
}

sub multi_glob {
    my @res;
    for my $pat (@_) {
	my @x = glob($pat);
	if (@x) {
	    push @res, @x;
	} else {
	    Warn("Nothing matches $pat");
	}
    }
    return @res;
}

sub resolve_link {
    my $f = shift;
    my @r;
    if (-f $f) {
	push @r, `readlink -f $f`;
	chomp(@r);
    } else {
	Err("$f is not a symlink to file");
    }
    return @r;
}

my %ino;
sub do_disk_files
{
    my $props = shift;
    my $dest = fix_tgt_maybe_dir(shift);
    my @files = multi_glob(@_);
    my @links;
    foreach my $f (@files) {
	my @s = lstat($f);
	if (!@s) {
	    Err("$f: $!");
	    next;
	}
	my %info = %$props;
	my ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size,
	    $atime, $mtime, $ctime, $blksize, $blocks) = @s;
	$info{MODE} ||= $mode & 07777;
	$info{OWNER} ||= own_adj($uid, $gid, 1);
	my $d = make_dest($dest, $f);
	if (-f _) {
	    $ino = "$dev:$ino";
	    if ($ino{$ino}) {
		$info{FILE_TYPE} = 'H';
		$info{LINK} = $ino{$ino};
	    } else {
		$ino{$ino} = $d;
		$info{FILE_TYPE} = 'F';
		$info{SIZE} = $size;
		$info{DISK_FILE} = $f;
	    }
	} elsif (-l _) {
	    if ($info{NOLINK}) {
		push @links, resolve_link($f);
		next;
	    } else {
		$info{FILE_TYPE} = 'S';
		$info{LINK} = readlink($f);
	    }
	} elsif (-d _) {
	    $info{FILE_TYPE} = 'D';
	} elsif (-b _) {
	    $info{FILE_TYPE} = 'B';
	    $info{DEVICE_NUM} = $rdev;
	} elsif (-c _) {
	    $info{FILE_TYPE} = 'C';
	    $info{DEVICE_NUM} = $rdev;
	} else {
	    Err("Not copying special file $f\n");
	    next;
	}
	add_f($d, \%info);
    }
    if (@links) {
	do_disk_files($props, $dest, @links);
    }
}


my $in_ar;
my $IN_RPM=1;
my $IN_OPKG=2;
my $in_pkg;
my $ar_num = 0; # the current ar being processed
my @ar_name;
my %ar_contents; # of the current ar being processed, maps file_name => attributes.
my @ar_extract; # maps $ar_num => list of files to extract from $ar_name[$ar_num]
my %ar_did; # list of all files to be extracted from current archive.

sub rst {
    $in_pkg = 0;
    # go back to starting dir
    # save current archive info
    # reset archive data for next one
    $pwd = '.';
    if (@_) {
	my $loc = shift;
	$pwd = abs_path($loc);
	# FIXME - chdir($pwd) || Die "cd $pwd";
    }
    return unless $in_ar;
    $in_ar = 0;
    my @extracts = sort keys %ar_did;
    push @ar_extract, \@extracts;
    %ar_did = ();
    %ar_contents = ();
    $ar_num++;
    $ar_cd = "";
}

sub ar_glob {
    my @res;
    my @ar_file_names = keys %ar_contents;
    return if $in_ar < 0;
    for my $pat (@_) {
	my $px = ar_path($pat);
	my $recurse = $px =~ s,/\.\.\.$,,;
	$px =~ s,\.,\\.,g;
	$px =~ s,(?<!\\)\*,[^/]*,g;
	$px =~ s,(?<!\\)\?,[^/],g;
	if ($recurse) {
	    $px = "^$px/(.*)\$";
	    for my $arf (@ar_file_names) {
		next unless $arf =~ /$px/;
		my $rel_path = $1;
		if ($rel_path =~ m,(.*/).+,) {
		    push @res, $1, $arf;
		} else {
		    push @res, "", $arf;
		}
	    }
	} else {
	    $px = "^$px/?\$";
	    my @match = grep { /$px/ } @ar_file_names;
	    grep { s,/$,, } @match;
	    Err("Nothing matches $pat  (px=$px)\n") unless @match;
	    push @res, "", $_ for @match;
	}
    }
    return @res;
}

sub do_ar_files {
    my $props = shift;
    my $dest = fix_tgt_maybe_dir(shift);
    my @glob_res = ar_glob(@_);
    while (@glob_res) {
	my $d = shift @glob_res;
	my $f = shift @glob_res;
	my $desc = $ar_contents{$f};
	my %dx = %$desc;
	while (my ($k, $v) = each %$props) {
	    $dx{$k} = $v;
	}
	if ($dx{FILE_TYPE} =~ /[BCSDP]/) {
	    # all set
	} elsif ($dx{FILE_TYPE} eq 'F') {
	    if ($ar_did{$f}) {
		# this is the "real" file in the archive, but we already
		# decided to copy out something that was linked to it,
		# so make this a hard link to that.
		$dx{FILE_TYPE} = 'H';
		$dx{LINK} = $ar_did{$f};
	    } else {
		$ar_did{$f} = $f;
		$dx{DISK_FILE} = "$tmp_dir/$ar_num/$f";
	    }
	} elsif ($dx{FILE_TYPE} eq 'H') {
	    my $ff = $dx{LINK};
	    if ($ar_did{$ff}) {
		# Already indicated we need to copy out the
		# name that has the real contents.
	    } else {
		# instead of being a link this will be the
		# file in the next archive. (unless it gets
		# reordered later.
		$ar_did{$ff} = $f;
		$dx{DISK_FILE} = "$tmp_dir/$ar_num/$ff";
		$dx{FILE_TYPE} = 'F';
	    }
	} else {
	    Die("I've confused myself with $f\n");
	}
	add_f(make_dest("$dest$d", $f), \%dx);
    }
}

sub pax_ar($) {
    my $ar = shift;
    $ar = "$orig_pwd/$ar" unless $ar =~ /^\//;
    my @x = ("-f", $ar);
    if ($ar =~ /\.gz$/) {
	unshift @x, "-z";
    } elsif ($ar =~ /\.bz2$/) {
	unshift @x, "-j";
    }
    return @x;
}

sub tar_read_contents {
    # Handles any archive tar can deal with, incl cpio & pax.
    my $ar = abs_path(shift);
    my $cmd= join(" ", ("pax", '-E', '0', "-O", "-v", pax_ar($ar)));
    my $mode;
    my $user;
    my $group;
    my $rdev;
    my $datetime;
    my $path;
    my $link;
    my $xtra;
    my $size;
    if (open my $fh, "-|", $cmd) {
	while (<$fh>) {
	    my $type = substr($_, 0, 1);
	    if ($type eq '-') {
		if (/.(.........)\s+\d+\s+(\S+)\s+(\S+)\s*(\d+)\s*(\S+\s+\S+\s+\S+)\s+(\S+)\s+==\s+(\S+)$/){
		    # cpio hard link
		    ($mode, $user, $group, $size, $datetime, $path, $link) = ($1, $2, $3, $4, $5, $6, fix_tgt($7));
		    if ($ar_contents{$link}) {
			$ar_contents{$path} = { FILE_TYPE => 'H',
						OWNER => own_adj($user, $group, 0),
						MODE => mode_val($mode),
						LINK => $link };
		    } else {
			Err("Absent hardlink: $path link to $link\n");
		    }
		    next;
		} elsif (/.(.........)\s+\d+\s+(\S+)\s+(\S+)\s*(\d+)\s*(\S+\s+\S+\s+\S+)\s+(\S+)$/){
		    ($mode, $user, $group, $size, $datetime, $path) = ($1, $2, $3, $4, $5, $6);
		    $ar_contents{$path} = { FILE_TYPE => 'F',
					    OWNER => own_adj($user, $group, 0),
					    SIZE => $size,
					    MODE => mode_val($mode) };
		    next;
		}
	    } elsif ($type eq 'd') {
		if (/.(.........)\s+\d+\s+(\S+)\s+(\S+)\s*\d+\s*(\S+\s+\S+\s+\S+)\s+(\S+)$/){
		    ($mode, $user, $group, $datetime, $path) = ($1, $2, $3, $4, $5);
		    $ar_contents{$path} = { FILE_TYPE => 'D',
					    OWNER => own_adj($user, $group, 0),
					    MODE => mode_val($mode) },
		    next;
		}
	    } elsif ($type eq 'l') {
		if (/.(.........)\s+\d+\s+(\S+)\s+(\S+)\s*\d+\s*(\S+\s+\S+\s+\S+)\s+(\S+)\s+=>\s+(\S+)/) {
		    ($mode, $user, $group, $datetime, $path, $link) = ($1, $2, $3, $4, $5, $6);
		    $ar_contents{$path} = { FILE_TYPE => 'S',
					    OWNER => own_adj($user, $group, 0),
					    MODE => mode_val($mode),
					    LINK => $link };
		    next;
		}
	    } elsif ($type eq 'h')  {
		# tar backwards hard link
		if (/.(.........) (\S+)\/(\S+)\s*\d+\s*(\S+\s+\S+)\s+(\S+) link to (\S+)$/) {
		    ($mode, $user, $group, $datetime, $path, $link) = ($1, $2, $3, $4, $5, fix_tgt($6));
		    if ($ar_contents{$link}) {
			$ar_contents{$path} = { FILE_TYPE => 'H',
						OWNER => own_adj($user, $group, 0),
						MODE => mode_val($mode),
						LINK => $link };
		    } else {
			Err("Absent tar hardlink: $path link to $link\n");
		    }
		    next;
		}
	    } elsif ($type eq 'b' | $type eq 'c') {
		if (/.(.........)\s+\d+\s+(\S+)\s+(\S+)\s*(\d+),\s*(\d+)\s*(\S+\s+\S+\s+\S+)\s+(\S+)$/){
		    ($mode, $user, $group, $rdev, $datetime, $path) = ($1, $2, $3, ($4<<8)|$5, $6, $7);
		    $ar_contents{$path} = { FILE_TYPE => "\U$type",
					    OWNER => own_adj($user, $group, 0),
					    MODE => mode_val($mode),
					    DEVICE_NUM => $rdev };
		    next;
		}
	    } elsif ($type eq 'p') {
		next if (/pax:/);
		if (/.(.........)\s+\d+\s+(\S+)\s+(\S+)\s*(\d+)\s*(\S+\s+\S+\s+\S+)\s+(\S+)$/) {
		    ($mode, $user, $group, $size, $datetime, $path) = ($1, $2, $3, $4, $5, $6);
		    $ar_contents{$path} = { FILE_TYPE => "\U$type",
					    OWNER => own_adj($user, $group, 0),
					    MODE => mode_val($mode) };
		    next;
		}
	    }
	    Err("Can't parse pax output\n $_");
	}
	close($fh);

	#dmp(\%ar_contents);
	#push @ar_file_names, grep { $ar_contents{$_}{FILE_TYPE} ne 'D' } keys %ar_contents;
    } else {
	Die("$!: $cmd");
    }
}

sub rpm_read_contents {
    # bad hardlink handling, although cpio is fine with it....
    Err("RPM2CPIO can generate archive that can't be processed by PAX\n");
    my $rpm = abs_path(shift);
    my $ix = $#ar_name;
    $ar_name[$ix] = "$tmp_dir/$ix.tar";
    $need_rm = 1;
    sys("mkdir", "-p", "$tmp_dir");
    sys("rpm2cpio $rpm >$ar_name[$ix]");
    exit 1 if $?;
    tar_read_contents($ar_name[$ix]);
}

sub deb_read_contents {
    my $deb = abs_path(shift);
    my $ix = $#ar_name;
    $ar_name[$ix] = "$tmp_dir/$ix.tar";
    $need_rm = 1;
    sys("mkdir", "-p", $tmp_dir);
    sys("ar -p $deb data.tar.gz | gunzip >$ar_name[$ix]");
    exit 1 if $?;
    tar_read_contents($ar_name[$ix]);
}

sub ar_read_contents {
    my $ar = abs_path(shift);
    $in_ar = 1;
    push @ar_name, $ar;
    if ($ar =~ /.rpm/) {
	rpm_read_contents($ar);
    } elsif ($ar =~ /.cpio\.?/ || $ar =~ /.pax\.?/ || $ar =~ /.tar\.?/) {
	tar_read_contents($ar);
    } elsif ($ar =~ /.deb$/ || $ar =~ /.ipk$/) {
	deb_read_contents($ar);
    } else {
	# iso?anything else?
	Err("$ar is not a recognized archive\n".
	    "  (if you meant a directory add / to the end.)\n");
	$in_ar = 1;
    }
}

sub parse_mode($) {
    my $mode = oct(shift);
    if (($mode == 0)
	|| ($mode & ~06777)
	|| (($mode & 04000) & !($mode & 0100))
	|| (($mode & 02000) & !($mode & 0010))) {
	Err(sprintf "Invalid mode %o", $mode);
	return 0644;
    }
    return $mode;
}

sub get_props ($) {
    my $a = shift;
    my %d;
    while (@$a) {
	if ($a->[0] =~ /^mode=([0-7]+)$/) {
	    shift @$a;
	    $d{MODE} = parse_mode("0"+$1);
	} elsif ($a->[0] =~ /^owner=(\S+)[.:](\S+)$/) {
	    shift @$a;
	    $d{OWNER} = own_adj($1, $2, 0);
	} elsif ($a->[0] =~ /^nolink=1$/) {
	    shift @$a;
	    $d{NOLINK} = 1;
	} elsif ($a->[0] =~ /^[a-z]+=/) {
	    Err("Invalid option '$a->[0]'");
	    shift @$a;
	} else {
	    last;
	}
    }
    return \%d;
}

my %cmd_dict;

sub cmd_noop {
    # most commands do nothing when generating dependencies.
}

sub cmd_reset {
    # Change directory back to the start.  Finish processing archive.
    rst();
}

my $did_id = 0;
sub cmd_id {
    # set the user/group files
    if ($did_id++) {
	Err("Already set id files (was this command after a from?)\n");
    } else {
	setup_uid_gid_dicts($_[0], $_[1]);
	push @deps,  abs_path($_[0]), abs_path($_[1]);
    }
}

sub cmd_from {

    # If we don't already have id's defined.
    cmd_id('/etc/passwd', '/etc/group') unless $did_id;

    # Do the from command. If we've got a dir, cd there.
    # If we've got a file, it must be an archive - read it all now.
    my $loc = shift;
    if ($loc =~ /\/$/) {
	rst($loc);
    } elsif (-d $loc) {
	Err("Directory must have trailing /\n");
	rst($loc);
    } else {
	rst();
	ar_read_contents(abs_path($loc));
    }
}

sub cmd_rpm {
    my $off = shift;
    my $d = "$tmp_dir/newfs";
    $d = "$d/$off" unless $off eq '.';
    mkpath($d);
    rst($d);
    $in_pkg = $IN_RPM;
    $need_rm = 1;
    for my $rpm (@_) {
	sysx("rpm2cpio $rpm | (cd $d ; cpio --make-directories --quiet -i)");
	exit 1 if $errors;
    }
}

sub cmd_dep_rpm {
    shift;
    $in_pkg = $IN_RPM;
    push @deps, map { abs_path($_) } @_;
}

sub cmd_opkg {
    my $d = "$tmp_dir/newfs";
    rst($d);
    $in_pkg = $IN_OPKG;
    $need_rm = 1;
    mkpath("$d/usr/lib64/opkg", "$d/etc/opkg");
    open my $fh, ">", "$d/etc/opkg/arch.conf";
    print $fh "arch all 1\n";
    print $fh "arch any 6\n";
    print $fh "arch noarch 11\n";
    print $fh "arch x86_64 16\n";
    print $fh "arch x86-generic-64 21\n";
    close $fh;
    my @opkg_opts = grep { /^--/ } @_;
    @_ = grep { !/^--/ } @_;
    my $opkg_cmd = shift @_;
    if (!$errors) {
	sysx("mvcge-distro/sdk/iosxe-container/sysroots/x86_64-xesdk-linux/usr/bin/opkg -o $d --conf build/util/opkg/usr/opkg.conf @opkg_opts $opkg_cmd @_ >>$log_file_name");
	if ($errors || (system("grep -q ERROR $log_file_name") == 0)) {
	    system("cat $log_file_name");
	    exit 1;
	}
    }
}

sub cmd_dep_opkg {
    rst();
    @_ = grep { !/^--/ } @_;
    shift @_;
    $in_pkg = $IN_OPKG;
    push @deps, map { abs_path($_) } @_;
}


sub cmd_dep_from {
    # do the from command for deps - do cd for dir, print archive name
    # for file, but don't bother reading it.
    my $loc = shift;
    if ($loc =~ /\/$/) {
	rst($loc);
    } else {
	rst();
	check_have_output();
	push @deps, abs_path($loc);
	$in_ar = 1;
    }
}


sub cmd_cd {
    # cd to a place in the archive - always from root. validate it
    my $cd = fix_tgt(shift);
    if (!$in_ar) {
	Err("Only meaningful when processing an archive\n");
	return;
    }
    $ar_cd = $cd;
    return unless $cd;
    my $desc = $ar_contents{$cd};
    if (!$desc) {
	# it's not explicitly there, maybe implict?
	for my $k (keys %ar_contents) {
	    return if $k =~ /^$cd\//;
	}
	Err("No directory $cd in archive\n");
    } elsif ($desc->{FILE_TYPE} ne 'D') {
	Err("Not a directory: $cd\n");
    }
}

sub cmd_ii {
    my $kw = shift;
    if ($in_ii) {
	if (!defined $ii_data{$kw}) {
	    Err("Invalid ii info type $kw\n");
	} elsif ($ii_data{$kw}) {
	    Err("Ii $kw info already set\n");
	} elsif ($kw eq 'models') {
	    for (@_) {
		$ii_files_for_model{$_} = [];
	    }
	} else {
	    if ($kw eq 'type') {
		if ($#_ || !$ii_types{$_[0]}) {
		    Err("Invalid ii type @_\n");
		}
	    }
	    $ii_data{$kw} = "@_";
	}
    } else {
	Err("The ii command is only valid for system install images\n");
    }
}

sub cmd_models {
    if ($in_ii) {
	$ii_models_set = 1;
	@ii_models = uniq(@_);
	for (@ii_models) {
	    if (!$ii_files_for_model{$_}) {
		Err("Unknown model $_\n");
	    }
	}
    } else {
	Err("The model command is only valid for system install images\n");
    }
}

sub cmd_dir {
    # Add one or more directories to the archive.
    my $props = shift;
    $props->{OWNER} ||= [ $default_uid, $default_gid];
    $props->{MODE} ||= 0777;
    for my $d (@_) {
	my %info = %$props;
	$info{FILE_TYPE} = 'D';
	add_f($d, \%info);
    }
}

sub cmd_ignore {
    # pretend specified files aren't in the archive.
    if ($in_ar) {
	for my $f (@_) {
	    my $cnt = 0;
	    if ($f =~ s/\/\.\.\.$/\//) {
		my $l = length($f);
		for my $k (keys %ar_contents) {
		    if ($f eq substr($k, 0, $l)) {
			delete $ar_contents{$k};
			$cnt++;
		    }
		}
	    } elsif ($ar_contents{$f}) {
		$cnt++;
		delete $ar_contents{$f};
	    }
	    Warn("No file $f (can't ignore)\n") unless $cnt;
	}
    } elsif ($in_pkg) {
	for my $f (@_) {
	    my $cnt = 0;
	    if ($f =~ s/\/\.\.\.$/\//) {
		sysx("rm -fr $pwd/$f");
	    } else {
		sysx("rm $pwd/$f");
	    }
	}
    } else {
	Err("Must be in rpm, opkg, or archive to use ignore command\n");
    }
}

sub cmd_outflags {
    # options to pass to mkisofs/pax/...
    $out_options = "@_";
}

sub cmd_dep_ref {
    push @deps, @_;
}

my $out_file_name_set = 0;
sub cmd_dep_output {
    if ($out_file_name_set) {
	Err("Output file name already set to $out_file_name\n");
    }
    $out_file_name_set = 1;
    $out_file_name = shift;
    if ($out_file_name =~ /\.(pax|cpio|tar|iso|ext2|ext3)(\.gz|\.bz2|\.xz)?$/) {
	($out_fmt, $out_compress) = ($1, $2||"");
	if ($out_fmt eq 'tar') {
	    $out_fmt = 'pax';
	} elsif ($out_fmt eq 'cpio') {
	    $out_options ||= '--format=newc';
	}
	} elsif ($out_file_name =~ /\.ova$/) {
	$in_ova = 1;
	$out_compress = '';
	$out_fmt = 'pax';
    } elsif ($out_file_name =~ /\.ii$/) {
	$in_ii = 1;
	$out_compress = '';
	$out_fmt = 'pax';
    } elsif ($out_file_name =~ /\.ut$/) {
	$out_compress = '';
	$out_fmt = 'ut';
    } else {
	Err("Can't determine output file format.");
    }
}

sub cmd_output {
    cmd_dep_output(@_);
    if ($out_fmt eq 'ut') {
	open $out_file, ">", $out_file_name || die "$!: $out_file_name\n";
	print $out_file "#! /bin/sh\n", "set -xe\n", "rm -fr obj/ut\n";
    }
    $log_file_name = "$out_file_name.log";
    unlink($log_file_name);
}


sub check_have_output {
    return if $out_file_name;
    Err("Must use 'output FILENAME' command before this\n");
    $out_file_name = "/dev/null";
}

sub cmd_device {
    # Add a device node (char and block only) to the archive.
    my $props = shift @_;
    my $type = shift @_;
    if ($type eq 'p') {
	if ($#_ != 0) {
	    Err("Expecteted device [opts] p devname\n");
	    return;
	}
    } elsif ($#_ != 1) {
	Err("Expecteted device [opts] b|c maj,min devname\n");
    } else {
	if ($type !~ /[bc]/) {
	    Err("Invalid device type '$type'\n");
	    return;
	}
	my $majmin = shift @_;
	if ($majmin !~ /(\d+),(\d+)/ || ($1 > 255) || ($2 > 255)) {
	    Err("Invalid device number $majmin\n");
	    return;
	}
	$props->{DEVICE_NUM} = ($1 << 8) | $2;
    }
    $props->{OWNER} ||= [0, 0];
    $props->{MODE} ||= 0600;
    $props->{FILE_TYPE} = "\U$type";
    my $tgt = shift @_;
    add_f($tgt, $props);
}

sub cmd_hardlink {
    # Add (a) hardlink(s) to a file already in the archive
    # (tar restriction - real file must be present earlier in archive).
    my $props = shift;
    my $src = fix_tgt(shift);
    my $src_info = $fd{$src};
    if (!defined($src_info)) {
	Err("Must have original file $src already in archive\n");
	return;
    } elsif ($src_info->{FILE_TYPE} eq 'H') {
	$src = $src_info->{LINK};
    } elsif ($src_info->{FILE_TYPE} ne 'F') {
	Err("Hard link must be to regular file, $src isn't");
	return;
    }
    $props->{OWNER} ||= $src_info->{OWNER};
    $props->{MODE} ||= $src_info->{MODE};
    $props->{FILE_TYPE} = 'H';
    $props->{LINK} = $src;
    for my $tgt (@_) {
	my %info = %$props;
	add_f($tgt, \%info);
    }
}

sub cmd_include {
    my $fn = shift;
    my $again = $dependencies_only && $fn =~ /^obj\//;
    push @deps, $fn if $dependencies_only;
    while (1) {
	if (open my $fh, "<", $fn) {
	    unshift @source_stack, [$fh, $fn, 0];
	    return;
	}
	last unless $again;
	system("build/mk $fn NO_IMAGES_MK=1 >&2");
	$again = 0;
    }
    Err("$!: $fn\n");
}

sub cmd_symlink {
    # Add a symbolic link to the archive.
    my $props = shift;
    my $link_contents = shift;
    $props->{OWNER} ||= [ 0, 0 ];
    $props->{MODE} ||= 0777;
    $props->{LINK} = $link_contents;
    $props->{FILE_TYPE} = 'S';
    for my $tgt (@_) {
	add_f($tgt, $props);
    }
}

sub cmd_copy {
    # Copy files from the host or the current archive to the archive.
    my $props = shift;
    my $tgt = pop @_;
    if ($tgt !~ /\/$/) {
	my $t = fix_tgt($tgt);
	if (defined($fd{$t}) && $fd{$t}{FILE_TYPE} eq 'D') {
	    # would be ok to warn now, but would break in --deps run.
	    Err("$tgt needs to be $tgt/");
	    $tgt .= '/';
	}
    }
    if ($in_ar) {
	do_ar_files($props, $tgt, @_);
    } elsif ($in_pkg) {
	Err("All of non-ignored opkg/rpm is used.\n");
    } else {
	do_disk_files($props, $tgt, map { abs_path($_) } @_);
    }
}

sub cmd_dep_copy {
    # Report deps from copy command.
    # Archive dependency already reported so skip that.
    # Just print the full path to the source files - globs don't get expanded.
    return if $in_ar || $in_pkg;
    check_have_output();
    my $props = shift;
    my $tgt = pop @_;
    push @deps, map { abs_path($_) } @_;
}


sub expand($) {
    my $line = shift;
    while ($line =~ /(.*)\$([A-Za-z0-9_]+)(.*)/) {
	if (defined $Img::{$2}) {
	    $line = $1.${$Img::{$2}}.$3;
	} else {
	    Err("Undefined $2");
	    $line = $1.$2;
	}
    }
    while ($line =~ /(.*)\${([A-Za-z0-9_]+)}(.*)/) {
	if (defined $Img::{$2}) {
	    $line = $1.${$Img::{$2}}.$3;
	} else {
	    Err("Undefined $2");
	    $line = $1.$2;
	}
    }
    return $line;
}

sub ev($) {
    my $str = shift;
    local $SIG{__WARN__} = sub { die $_[0] };
    my $result = eval "{ package Img; $str; }";
    my $t = $@;
    if ($t) {
	if ($t =~ /(.*) \(at eval d+\) line \d+./) {
	    Die($1);
	} else {
	    Die($t);
	}
    }
    return $result;
}


sub parse() {
    # Read commands while we've got them.
    # %cmd_dict gives rough guidance on how to parse
    # and vector to appropriate cmd_* functions.
    my @if_stack; # [ looking-for-true-clause, currently-true, did-else ]
    my $if_true = 1;
    while (@source_stack) {
	my $fh = $source_stack[0][0];
	$_ = <$fh>;
	if (!$_) {
	    shift @source_stack;
	    next;
	}
	chomp;
	while (1) {
	    $source_stack[0][2]++;
	    s/#.*//;
	    last unless /(.*)\\$/;
	    $_ = "$1".<$fh>;
	}
	if (/^\s*if\s*(.*)/) {
	    if ($if_true) {
		# starting a "live" if.
		$if_true = ev($1) ? 1 : 0;
		unshift @if_stack, [!$if_true, $if_true, 0];
	    } else {
		# ignore whole if.
		unshift @if_stack, [0, 0, 0];
	    }
	    next;
	} elsif (/^\s*elif\s*(.*)/) {
	    if (!@if_stack) {
		Die("Not in an if\n");
	    } elsif ($if_stack[0][2]) {
		Die("Missing endif (or elif after else)\n");
	    } elsif ($if_stack[0][0])  {
		# looking for a true case
		if (ev($1)) {
		    # found it
		    $if_stack[0][0] = 0;
		    $if_stack[0][1] = $if_true = 1;
		}
	    }
	    next;
	} elsif (/^\s*else\s*$/) {
	    if (!@if_stack) {
		Die("Not in an if\n");
	    } elsif ($if_stack[0][2]++) {
		Die("Missing endif (or else after else)\n");
	    } elsif ($if_stack[0][0]) {
		$if_stack[0][0] = 0;
		$if_stack[0][1] = $if_true = 1;
	    } else {
		$if_true = 0;
	    }
	    next;
	} elsif (/^\s*endif\s*$/) {
	    if (@if_stack) {
		shift @if_stack;
		shift @if_stack;
		$if_true = @if_stack ? $if_stack[0][1] : 1;
	    } else {
		Die("Not in an if");
	    }
	    next;
	}
	next unless $if_true;
	if (/^perl\s+(.*)/) {
	    ev($1);
	    next;
	} elsif (/^final_action\s(.*)/) {
	    push @final_actions, $1;
	    next
	}
	$_ = expand($_);
	my @F = split /\s+/;
	next unless @F;
	shift @F if $F[0] eq "";
	Warn("DEBUG: @F") if $debug > 1;
	my $cmd = shift @F;
	my $cmd_info = $cmd_dict{$cmd};
	if (!defined($cmd_info)) {
	    Err("Invalid command '$cmd'");
	} else {
	    my ($fnn, $fnd, $use_props, $min_args, $max_args) = @$cmd_info;
	    my $props = get_props(\@F) if $use_props;
	    my $argc = scalar @F;
	    unshift @F, $props if $use_props;
	    if ($argc < $min_args) {
		Err("Too few arguments for $cmd");
	    } elsif ($argc > $max_args) {
		Err("Too many arguments for $cmd");
	    } else {
		my $fn = $dependencies_only ? $fnd : $fnn;
		&{$fn}(@F);
	    }
	}
    }
    rst();
}

sub sys {
    logx("+", @_);
    Die("Doing @_") if system(@_);
}

sub clean_up {
    # on exit or error, try to get rid of the temp dir.
    if ($need_rm) {
	if ($debug) {
	    print STDERR "Leaving temp dir $tmp_dir !!!\n";
	} else {
	    system("rm -fr $tmp_dir");
	}
    }
    unlink($out_file_name) if ($errors && $out_file_name);
    exit $errors ? 1 : 0;
}

$SIG{INT} = \&clean_up;
$SIG{TERM} = \&clean_up;

sub dump_other_ars()
{
    for (my $i = 0; $i < $ar_num; $i++) {
	if (@{$ar_extract[$i]}) {
	    Err("No support for archive file extraction in UT image")
		if $out_fmt eq 'ut';
	    sysx("mkdir", "-p", "$tmp_dir/$i");
	    chdir("$tmp_dir/$i");
	    my @cmd = ("pax", '-O', '-E', '0', '-p', 'e', '-r',
		       pax_ar($ar_name[$i]), @{$ar_extract[$i]});
	    sysx(@cmd);
	    chdir($orig_pwd);
	}
    }
}

sub set_tmp_mode($$) {
    my ($tk, $v) = @_;
    my ($u, $g) = @{$v->{OWNER}};
    if ($out_fmt ne 'ut') {
	if ($v->{FILE_TYPE} eq 'S') {
            sysx("fakeroot chown -h $u:$g $tk");
		#sysx("chown -h $u:$g $tk");
	} 
	else {
		my $ret_val = system("fakeroot chown $u:$g $tk");
		#my $ret_val = system("chown $u:$g $tk");
		if ($ret_val == 0){
		    my $vmode = sprintf("%o", $v->{MODE});
		    my $ret_val2 = system("fakeroot chmod $vmode $tk");
		    #my $ret_val2 = system("chmod $vmode $tk");
		    if ($ret_val2 != 0){
		        Err(sprintf("Error: chmod %s %o", $tk, $v->{MODE}));
	            }
	        }
		else {
	            Err("Error: chown $tk $u:$g\n");
	        }
	}
    } else {
	# in UT, can't chown, can only chmod
	if ($v->{FILE_TYPE} ne 'S') {
	    sysx(sprintf("fakeroot chmod %o %s", $v->{MODE}, $tk));
	}
    }
}



sub logx {
    Err("Output file name should be set first\n") unless $out_file_name_set;
    if ($log_file_name) {
	if (open my $log, ">>", $log_file_name) {
	    print $log "@_\n";
	    close $log;
	}
    } elsif ($debug) {
	print STDERR "@_\n";
    }

}

# System command to affect target fs.
sub sysx {
    if ($out_fmt ne 'ut') {
	logx("+", @_);
	if (system(@_)) {
	    my $exit_code = $?;
	    if ($exit_code >> 8) {
		$exit_code >>= 8;
		Err("Error[$exit_code]: @_");
	    } else {
		$exit_code &= 127;
		Err("Signal[$exit_code]: @_");
	    }
	}
    } else {
	# UT image is just commands to setup UT, no copying/chmod/etc.
	# happens to create the UT "image".
	print $out_file "@_\n";
    }
}

my %dirs_made;
sub mkpath {
    for my $d (@_) {
	next if $dirs_made{$d}++;
	next if -d $d && $out_fmt ne 'ut';
	sysx("mkdir -p $d");
    }
}

sub setup_temp_fs ($) {
    my $top = shift;
    my ($k,$v,$tk);
    while (($k,$v) = each %fd) {
	$tk = "$top/$k";
	mkpath(dirname($tk));
	if ($v->{FILE_TYPE} eq 'F') {
	    sysx("cp -lp '$v->{DISK_FILE}' '$tk' 2>/dev/null ".
		 "|| cp -p '$v->{DISK_FILE}' '$tk'");
	} elsif ($v->{FILE_TYPE} eq 'D') {
	    mkpath($tk);
	    # fix perms later.
	    next;
	} elsif ($v->{FILE_TYPE} eq 'S') {
	    if (!symlink($v->{LINK}, $tk)) {
		Err("making symlink $tk => $v->{LINK}");
	    }
	} elsif ($v->{FILE_TYPE} eq 'C' ||
		 $v->{FILE_TYPE} eq 'B') {
	    my ($maj, $min) = ($v->{DEVICE_NUM} >> 8, $v->{DEVICE_NUM} & 255);
	    sysx("fakeroot mknod $tk \L$v->{FILE_TYPE} $maj $min");
	    #sysx("mknod $tk \L$v->{FILE_TYPE} $maj $min");
	} elsif ($v->{FILE_TYPE} eq 'P') {
	    sysx("fakeroot mknod $tk \L$v->{FILE_TYPE}");
	    #sysx("mknod $tk \L$v->{FILE_TYPE}");
	} elsif ($v->{FILE_TYPE} eq 'H') {
	    # skip for now
	    next;
	} else {
	    Err("Don't know how to do type $v->{FILE_TYPE} for $k");
	    next;
	}
	set_tmp_mode("$tk", $v) unless $errors;
    }
    while (($k,$v) = each %fd) {
	next unless $v->{FILE_TYPE} eq 'H';
	my $tl = "$top/$v->{LINK}";
	$tk = "$top/$k";
	if (link($tl, $tk)) {
	    set_tmp_mode($tk, $v);
	} else {
	    Err("Couldn't link $tl $tk");
	}
    }
    while (($k,$v) = each %fd) {
	set_tmp_mode("$top/$k", $v) if $v->{FILE_TYPE} eq 'D';
    }
}

sub make_ii_manifest($) {
    my $top = shift;
    open my $fh, "|-", "gzip >$top/manifest.gz";
    my $rel_typ = $ii_data{type} || "full";
    print $fh "version 1\n",
      "type $rel_typ\n",
      "release $ii_data{release}\n";
    while (my ($k, $v) = each %ii_files_for_model) {
	print $fh "model $k @$v\n";
    }
    my @data = `find $top -type f | xargs md5sum`;
    for my $d (@data) {
	if ($d =~ /(\S+)\s+$top\/(\S+)/) {
	    next if $2 eq "manifest.gz";
	    print $fh "md5sum $2 $1\n";
	}
    }
    close $fh;
}

sub make_ova_manifest($) {
    # looks like this is a tar of a one level directory
    # containing a .ovf and we need to create a .mk with the same name
    # containing the sha1's of all the files
    my $top = shift;

    # get file list
    opendir DIR, $top;
    my @dir = grep(!/^(\.|\.\.)$/,readdir DIR);
    closedir DIR;

    # get the .ovf
    # my @ovf = grep { /.ovf/ } @dir;
    #Die("Exactly one .ovf file required (have @ovf)") if $#ovf;

    # generate the .mf name
    my @ver = grep { /.ver/ } @dir;
    Die("Exactly one .ver file required (have @ver)") if $#ver;
    my $mf = "$top/$ver[0]";
    $mf =~ s/\.ver$/.mf/;

    # sha1sum everything and translate the output to what we want.
    open my $fh, ">", $mf;
    open my $pipe, "-|", "cd $top; sha1sum @dir";
    while (<$pipe>)  {
    /^(\S+)\s+(\S+)/;
    print $fh "SHA1($2)= $1\n";
    }
    close $fh;
    close $pipe;
}

#uncompress the tar files in one dir,and then delete the source files
my $tar_count = 0;
sub dir_tar($) {
    my $deal_dir = shift;
    $tar_count = 0;
    opendir DH, $deal_dir or Die("Cannot open $deal_dir!");
    foreach $filein(readdir DH){
	if ($filein =~ /\.[tar|ii|gz]/){
	    sysx("cd $deal_dir; tar xvf $filein >/dev/null 2>&1; rm -f $filein");
	    $tar_count += 1;
	}
    }
    close DH;
}

#generate .cert file from .mf
sub gen_cert($$) {
    my $file_name = shift;
    my $user_name = "`whoami`";
    my $top_dir = shift;
    my $SHA1 = `sha1sum $top_dir/$file_name.mf | sed "s/$file_name.mf//"`;
    my $SHA = `echo 3021300906052b0e03021a05000414$SHA1`;
    my $SIGNATURE =`ssh $user_name\@abrx-gtwy.cisco.com "signHash ASR1k_3PA_OVF dev $SHA" | head -n 7  | tail -n 1`;
    if ($SIGNATURE) {    
        sysx("echo \"SHA1($file_name.mf)= $SIGNATURE\" > $top_dir/$file_name.cert");
        sysx("echo \"-----BEGIN CERTIFICATE-----\" >> $top_dir/$file_name.cert");
        sysx("echo \"-----END CERTIFICATE-----\" >> $top_dir/$file_name.cert");
        print "Generate file $file_name.cert successfully!\n";
    } else {
        Die("ERROR:Can not get signature from abrx-gtwy.cisco.com! Failed to generate file $file_name.cert!");
    }
}

sub make_image($) {
    my %comp_prog = ("" => "",
		     ".gz" => " | gzip",
		     ".bz2" => " | bzip2",
		     ".xz" => " | xz");
    my $top = shift;
    if (@final_actions) {
	my $faf  ="$tmp_dir/final_action";
	open my $fa, ">", $faf;
	print $fa "#! /bin/bash -e\ncd $orig_pwd\nIMAGE_DIR=$top\n";
	print $fa join("\n", @final_actions), "\n";
	close $fa;
	chmod 0777, $faf;
	sysx($faf);
    }
    if ($out_fmt eq 'pax') {
	make_ii_manifest($top) if $in_ii;
	make_ova_manifest($top) if $in_ova;
  
	if ($in_ova) {
	my @ova_name = split '/', $out_file_name;
	my @head = split /\./, $ova_name[1];
	gen_cert($head[0], $top);
	sysx("(cd $top; tar cvf $head[0].ova *.iso *.mf *.ver *.xml *.cert; mv *.ova ../../)");
	} else {
	# fixme - * doesn't catch .xxx, but don't want files starting with ./
	sysx("(cd $top; pax -w $out_options *)".
	     "$comp_prog{$out_compress} >$out_file_name");
    }
    } elsif ($out_fmt eq 'cpio') {
	# fixme - * doesn't catch .xxx, but don't want files starting with ./
	sysx("(cd $top; (echo .; find *) | ".
	     "cpio --quiet -o $out_options)".
	     "$comp_prog{$out_compress} >$out_file_name"
	     );
    } elsif ($out_fmt eq 'iso') {
	my $boot_prog;
	if ($out_options =~ /-b\s+(\S+)/) {
	    # We tried to copy the files via hardlink, but mkisofs will update
	    # the boot program, which we may not have write access to.
	    # So make a copy we can update. 
	    $boot_prog = "$top/$1";
	    sysx("cp -p $boot_prog $boot_prog.tmp");
	    unlink($boot_prog);
	    rename("$boot_prog.tmp", $boot_prog);
	}
	
	if ($top =~ /utd-snort.iso/){
	    $tar_count = 0;
	    for (;;){
                dir_tar($top);
		if ($tar_count eq 0){
		    last;
		}
	    }
	    my $curdir=getcwd;
	    sysx("$curdir/build/util/custom-file $top $curdir");
	}
	#sysx("mkisofs $out_options".
	#     "$comp_prog{$out_compress} $top >$out_file_name");
	sysx("mkisofs -R -o $out_file_name $top");
        sysx("isohybrid $out_file_name") if $boot_prog;
    } elsif ($out_fmt =~ /ext\d/) {
	$out_options |= "--reserved-blocks 0 --allow-holes";
	if ($out_options !~ /--size-in-blocks\s+\d+/) {
	    my $sz = `du -sk $top`;
	    $sz =~ s/\s.*//;
	    $sz = $sz + $sz>>2 + 100;
	    $out_options .= "--size-in-blocks $sz";
	}
	if ($out_options !~ /--(number-of-inodes|bytes-per-inode)\s+\d+/) {
	    my $in = $#{keys %fd};
	    $in = $in + $in >> 2 + 20;
	    $out_options .= "--number-of-inodes $in";
	}
	sysx("genext2fs $out_options --root $top".
	     "$comp_prog{$out_compress} >$out_file_name");
    } elsif ($out_fmt eq 'ut') {
	print $out_file "export TOP=\$PWD\n",
	"cd obj/ut\n",
	"./ut-driver\n",
	"cd \$TOP\n",
	": If it got here, it finshed OK\n";
	close($out_file);
	chmod(0777, $out_file_name);
    } else {
	Die("Wtf $out_file_name");
    }
}

sub uniq
{
    my %seen;
    for (@_) {
	$seen{$_}++;
    }
    return sort keys %seen;
}

(my $prog = $0) =~ s,.*/,,;

sub usage {
    print STDERR
	("Usage: $prog [ OPTIONS ] FILE\n",
	 " Options:\n",
	 "  --output=FILE | -o file   specify the output file\n",
	 "  --start-dir=DIR | -C DIR  cd to DIR before doing anything\n",
	 "  --tmp=DIR                 use DIR to hold tmp files ($tmp_dir)\n",
	 "  --deps                    generate dependency listing instead of archive\n",
	 "  --help                    longer help\n",
	);
    exit 1;
}

use Getopt::Long;
sub main {
    my $start_dir = '.';
    my $out_file;
    my $help;
    GetOptions('debug+' 	   => \$debug,
	       'dependencies|deps' => \$dependencies_only,
	       'help' 		   => \$help,
	       'output|o=s' 	   => \$out_file,
	       'start-dir|C=s' 	   => \$start_dir,
	       'tmp=s' 		   => \$tmp_dir,
	      ) or usage();
    exec("pod2man <$0 | nroff -man |" . ($ENV{"PAGER"} || "cat")) if $help;
    usage() if $#ARGV != 0;
    if ($< && !($dependencies_only || $out_file =~ /\.ut$/)) {
	Warn("Need to be running in fakeroot\n");
    }
    $tmp_dir = "$orig_pwd/$tmp_dir" if $tmp_dir !~ /^\//;
    my $many = 100000;
# cmd_dict value is array of:
#   function, dep_function, can_use_properties, min_args, max_args
    %cmd_dict =
	('cd' 		=> [ \&cmd_noop, \&cmd_cd,	 0, 1, 1 ],
	 'copy'		=> [ \&cmd_copy, \&cmd_dep_copy, 1, 2, $many ],
	 'device'	=> [ \&cmd_device, \&cmd_noop,	 1, 2, 3 ],
	 'directory'	=> [ \&cmd_dir, \&cmd_noop,	 1, 1, $many ],
	 'from' 	=> [ \&cmd_from, \&cmd_dep_from, 0, 1, 1 ],
	 'hardlink'	=> [ \&cmd_hardlink, \&cmd_noop, 1, 2, 2 ],
	 'id'		=> [ \&cmd_id, \&cmd_id,	 0, 2, 2 ],
	 'ignore' 	=> [ \&cmd_ignore, \&cmd_noop,	 0, 1, $many ],
	 'ii' 		=> [ \&cmd_ii, \&cmd_ii,	 0, 2, $many ],
	 'include'	=> [ \&cmd_include, \&cmd_include, 0, 1, 1 ],
	 'models'	=> [ \&cmd_models, \&cmd_models,   0, 0, $many ],
	 'rpm'		=> [ \&cmd_rpm, \&cmd_dep_rpm, 0, 2, $many ],
	 'opkg'		=> [ \&cmd_opkg, \&cmd_dep_opkg, 0, 2, $many ],
	 'output' 	=> [ \&cmd_output, \&cmd_dep_output, 0, 1, 1 ],
	 'outflags'	=> [ \&cmd_outflags, \&cmd_noop, 0, 0, $many ],
	 'ref'		=> [ \&cmd_noop, \&cmd_dep_ref,	 0, 1, $many ],
	 'reset' 	=> [ \&cmd_reset, \&cmd_reset,	 0, 0, 0 ],
	 'symlink' 	=> [ \&cmd_symlink, \&cmd_noop,	 1, 2, $many ],
	 );
    if ($out_file) {
	if ($dependencies_only) {
	    cmd_dep_output($out_file);
	} else {
	    cmd_output($out_file);
	}
    }
    cmd_include(shift @ARGV);
    parse();
    exit 1 if $errors;
    if ($dependencies_only)  {
	push @deps, $0;
	@deps = uniq(@deps);
	print "$out_file_name: @deps\n";
    } else {
	$need_rm = 1;
	dump_other_ars();
	my $tmpfs = ($out_fmt eq 'ut') ? "obj/ut" : "$tmp_dir/newfs";
	setup_temp_fs($tmpfs);
	exit 1 if $errors;
	make_image($tmpfs);
	if ($errors) {
	    unlink($out_file_name);
	    exit 1;
	}
    }
}

main();
END { clean_up(); };
