#!/usr/local/bin/perl -w

use strict;

##
## Config settings.
##

##
## WARNING: This script will make changes to your system by installing
## libraries.  Change the version numbers below, or replace them with
## the word "no" if you don't want this script to build and install them.

## Using hardcoded version numbers rather than getting the
## latest & greatest to get known-compatible versions.

## TODO: Make it all case sensitive or not (we're not consistent yet).

## A "IsVirtual => 1" package does not really exist; it's a mechanism
## for bundling dependancies and firing Actions.

##
## Use Force => 1 to cause a complete
##         download/unpack/configure/make/test/install
## Use FromScratch => 1 to skip the download if possible and do a
##         unpack/configure/make/test/install
##
## NOTE: I may reverse those, not sure.
##

use Cwd;

## For faster access...comment out if the mirror is broken for you
my $GNOME_URI = "ftp:://ftp.gnome.org/pub/GNOME/stable/sources";
$GNOME_URI = "ftp://ftp.yggdrasil.com/mirrors/site/ftp.gnome.org/pub/GNOME/stable/sources";
my %db = (
    WorkRoot      => cwd,

    DistBaseName  => "<%DistName%>-<%Version%>",
    WorkDir       => "<%WorkRoot%>",
    BuildRoot     => "<%WorkDir%>/build",
    BuildDir      => "<%BuildRoot%>/<%DistBaseName%>",
    DistsDir      => "<%WorkDir%>/dists",

    OriginalsDir  => "<%WorkDir%>/originals", # not used yet
    MetaInfoDir   => "<%BuildRoot%>/meta",
    DistName      => "<%Name%>",
    DistFileNames => "<%DistBaseName%>.tar.gz <%DistBaseName%>.tgz",
    DistFiles     => "<%DistsDir%>/<%DistFileNames%>",

    Perms         => 0755,  ## default perms for created files

    Path          => sub { $ENV{PATH} },

    BuildEnv      => {
        LD_LIBRARY_PATH => "<%Prefix%>/lib",
        PATH            => "<%Prefix%>/bin:<%Path%>",
        PERL5LIB        => "<%Prefix%>/lib",
    },

    Prefix        => "<%WorkRoot%>/www",

    Classes => {

        Package => {
            ConfigCmd        => "./configure <%ConfigParms%>",
            ConfigParms      => "--prefix=<%Prefix%>",
            DetectedRequires => [],
        },

        Package::PerlModule => {
            ConfigCmd   => "$^X Makefile.PL <%ConfigParms%> < /dev/null",
            TestCmd     => "make test",
            VersionFrom => "<%Name%>",
            ConfigParms => {
                PREFIX          => "<%Prefix%>",
                INSTALLSITELIB  => "<%Prefix%>/lib",
                INSTALLSITEARCH => "<%Prefix%>/lib",
            },
            DetectedRequires => sub {
                my $self = shift;
                $self->configure;
                $self->cd_to( "BuildDir" );

                my %prereqs;
                open F, "<Makefile" or die "$!opening Makefile";
                ## ummm, "inspired by" CPAN.pm with minor touchups
                while (<F>) {
                    last if /MakeMaker post_initialize section/;
                    my ( $prereqs ) = m/^#\s+PREREQ_PM\s+=>\s+(.+)/;
                    if ( $prereqs ) {
                        while ( $prereqs =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
                            # In case a prereq is mentioned twice, complain.
                            $prereqs{$1} = $2;
                        }
                        last;
                    }
                }
                close F;

                ## Ignore any that ship with Perl.
                ## TODO: fake up packages for those that don't.  Need
                ## the forthcoming CPANPLUS to sniff out the modules db.
                return [
                    grep {
                        my $is_standard_lib = eval {
                            $self->_run_build_cmd(
                                 q[perl -le ']
                                .q[BEGIN {]
                                .q[ use Config;]
                                .q[ @INC = grep index( $_, $Config{sitelib_stem} ), @INC]
                                .q[}]
                                .qq[use $_ ();'],
                            );
                            1;
                        };
                        ! $is_standard_lib,
                    } 
                    keys %prereqs
                ];
            },
            InstalledVersionQuery =>
                $^X . q[ -le ']
                .q[BEGIN {]
                .q[ use Config;]
                .q[ @INC = grep index( $_, $Config{sitelib_stem} ), @INC]
                .q[}]
                .q[use <%VersionFrom%> (); $_ = $<%VersionFrom%>::VERSION; s/_//; print $_'],
            DistName => sub {
                my $self = shift;
                my $v = $self->Name;
                $v =~ s/::/-/g;
                return $v;
            },
            CPAN_URIs => [qw(
                http://www.cpan.org/modules/by-authors/id
                ftp://ftp.cs.colorado.edu/pub/perl/CPAN/modules/by-authors/id
                ftp://cpan.nas.nasa.gov/pub/perl/CPAN/modules/by-authors/id
            )],
            Actions => [
                {
                    Phase   => "unpack",
                    Action  => "RunCmd",
                    CmdLine =>
$^X . q( -0777 -i.bak -pe 's/^(?!#)/BEGIN { use Config; \@INC = grep index( \$_, \$Config{sitelib_stem} ), \@INC }\n/m' Makefile.PL),
                    Comment =>
                        "Preventing perl Makefile.PL from searching in site_perl or site/lib",
                },
            ],
        },

        Package::GNOME => {
            InstalledVersionQuery => q{<%Prefix%>/bin/<%Name%>-config --version},
            GNOME_URIs => [qw(
                ftp://ftp.yggdrasil.com/mirrors/site/ftp.gnome.org/pub/GNOME/stable/sources
                ftp://ftp.gnome.org/pub/GNOME/stable/sources
            )],
            URIs => "<%GNOME_URIs%>/<%DistName%>/<%DistFileNames%>",
        },
    },

    Packages => [
        {
            Name        => "AxKit",
            Version     => "1.5",
            Style       => "PerlModule",
            # XML::Parser needs to find *our* expat
            Requires    => "mod_perl Apache::Filter XML::Parser",
            URIs        => "<%CPAN_URIs%>/M/MS/MSERGEANT/<%DistFileNames%>",
        },
        {
            Name        => "AxKit::XSP::Util",
            Version     => "1.5",
            Style       => "PerlModule",
            URIs        => "<%CPAN_URIs%>/M/MS/MSERGEANT/<%DistFileNames%>",
            Requires    => "mod_perl",
        },
        {
            Name        => "AxKit::XSP::ESQL",
            Version     => "1.4",
            Style       => "PerlModule",
            URIs        => "<%CPAN_URIs%>/M/MS/MSERGEANT/<%DistFileNames%>",
#            Requires    => "AxKit::XSP::Util",
        },
        {
            Name         => "apache",
            Version      => "1.3.23",
            DistBaseName => "apache_<%Version%>",
            URIs         => "http://httpd.apache.org/dist/httpd/<%DistFileNames%>",
        },
        {
            Name         => "Apache::Filter",
            Version      => "1.019",
            Style       => "PerlModule",
            URIs        => "<%CPAN_URIs%>/K/KW/KWILLIAMS/<%DistFileNames%>",
        },
        {
            Name        => "DBI",
            Version     => "1.21",
            Style       => "PerlModule",
            URIs        => "<%CPAN_URIs%>/T/TI/TIMB/<%DistFileNames%>",
        },
        {
            Name        => "DBD::CSV",
            Version     => "0.2001",
            Style       => "PerlModule",
            URIs        => "<%CPAN_URIs%>/J/JZ/JZUCKER/<%DistFileNames%>",
#            Requires    => "DBI SQL::Statement Text::CSV_XS",
            Actions => [
                {
                    Action => "DeleteFile",
                    Phase  => "unpack",
                    Path   => "t/ak-dbd.t",
                },
                {
                    Action => "DeleteFile",
                    Phase  => "unpack",
                    Path   => "test.pl",
                },
            ],
        },
        {
            Name        => "Digest::MD5",
            Version     => "2.16",
            Style       => "PerlModule",
            URIs        => "<%CPAN_URIs%>/G/GA/GAAS/<%DistFileNames%>",
        },
#        {
#            Name        => "expat",
#            Version     => "1.95.2",
#            URIs        => "http://prdownloads.sourceforge.net/expat/expat-1.95.2.tar.gz",
#            InstalledVersionQuery =>
#$^X . q{ -le 'print "1.95.2" if -e "<%Prefix%>/lib/libexpat.so"'},
#        },
        {
            Name         => "HTML::HeadParser",
            DistBaseName => "HTML-Parser-3.25",
            Version      => "2.15",
            Style        => "PerlModule",
            URIs         => "<%CPAN_URIs%>/G/GA/GAAS/<%DistFileNames%>",
        },
        {
            Name        => "HTTP::GHTTP",
            Version     => "1.06",
            Style       => "PerlModule",
            URIs        => "<%CPAN_URIs%>/M/MS/MSERGEANT/<%DistFileNames%>",
            Requires    => "libghttp",
        },
        {
            Name         => "HTML::Tagset",
            Version      => "3.03",
            Style        => "PerlModule",
            URIs         => "<%CPAN_URIs%>/S/SB/SBURKE/<%DistFileNames%>",
        },
        {
            Name        => "libghttp",
            Version     => "1.0.9",,
            Style       => "GNOME",
            InstalledVersionQuery => 
                $^X . q{ -ne 'print if s/^MODULE_VERSION.*-(\d.*\d).*/$1/' <%Prefix%>/lib/ghttpConf.sh},
        },
        {
            Name        => "libxml2",
            Version     => "2.4.13",
            Style       => "GNOME",
            URIs        => "<%GNOME_URIs%>/libxml/<%DistFileNames%>",
            InstalledVersionQuery => q{<%Prefix%>/bin/xml2-config --version},
        },
        {
            Name        => "libxslt",
            Version     => "1.0.10",
            Style       => "GNOME",
            Requires    => "libxml2",
            InstalledVersionQuery => q{<%Prefix%>/bin/xslt-config --version},
        },
        {
            Name        => "libwww-perl",
            Version     => "5.64",
            VersionFrom => "LWP",
            Style       => "PerlModule",
            URIs        => "<%CPAN_URIs%>/G/GA/GAAS/<%DistFileNames%>",
            Actions => [
                {
                    Phase   => "unpack",
                    Action  => "RunCmd",
                    CmdLine =>
$^X . q( -0777 -i.bak -pe 's/^(?!#)/require URI::URL;\n/m' lib/LWP/UserAgent.pm),
                    Comment =>
                        "Preventing perl Makefile.PL from searching in site_perl or site/lib",
                },
                {
                    Phase   => "configure",
                    Action  => "DeleteFile",
                    Path    => "t/live/ENABLED",
                    Comment => "Skip live tests in case of poor connectivity",
                },
            ],
        },
        {
            Name        => "mod_perl",
            Style       => "PerlModule",
            Version     => "1.26",
            URIs        => "http://perl.apache.org/dist/<%DistFileNames%>",
            Requires    => "libwww-perl URI HTML::HeadParser",
            ExternalComponents    => "apache",
            InstalledVersionQuery =>
                q{<%Prefix%>/bin/httpd -l | perl -lne 'print 1.26 if /mod_perl/'},
            ConfigParms => {
                USE_APACI       => 1,
                DO_HTTPD        => 1,
                APACHE_PREFIX   => "<%Prefix%>",
                PREFIX          => "<%Prefix%>",
                INSTALLSITELIB  => "<%Prefix%>/lib",
                INSTALLSITEARCH => "<%Prefix%>/lib",
                EVERYTHING      => 1,
            },
        },
        {
            Name        => "MIME::Base64",
            Version     => "2.12",
            Style       => "PerlModule",
            URIs        => "<%CPAN_URIs%>/G/GA/GAAS/<%DistFileNames%>",
        },
        {
            Name          => "Net::FTP",
            Version       => "2.58",
            Style         => "PerlModule",
            DistBaseName  => "libnet-1.0901",
            URIs          => "<%CPAN_URIs%>/G/GB/GBARR/<%DistFileNames%>",
        },
        {
            Name        => "SQL::Statement",
            Version     => "1.002",
            Style       => "PerlModule",
            URIs        => "<%CPAN_URIs%>/J/JZ/JZUCKER/<%DistFileNames%>",
        },
        {
            Name        => "Text::CSV_XS",
            Version     => "0.23",
            Style       => "PerlModule",
            URIs        => "<%CPAN_URIs%>/J/JW/JWIED/<%DistFileNames%>",
        },
        {
            Name        => "Time::Piece",
            Version     => "1.00",
            Style       => "PerlModule",
            URIs        => "<%CPAN_URIs%>/M/MS/MSERGEANT/<%DistFileNames%>",
        },
        {
            Name       => "URI",
            Version    => "1.18",
            Style      => "PerlModule",
            URIs       => "<%CPAN_URIs%>/G/GA/GAAS/<%DistFileNames%>",
            Actions => [
                {
                    Action => "DeleteFile",
                    Phase  => "unpack",
                    Path   => "t/heuristic.t",
                },
            ],
        },
        {
            Name       => "XML::NamespaceSupport",
            Version    => "1.04",
            Style      => "PerlModule",
            URIs       => "<%CPAN_URIs%>/R/RB/RBERJON/<%DistFileNames%>",
        },
        {
            Name       => "XML::SAX",
            Version    => "0.07",
            Style      => "PerlModule",
            URIs       => "<%CPAN_URIs%>/M/MS/MSERGEANT/<%DistFileNames%>",
        },
        {
            Name       => "XML::LibXML",
            Version    => "1.31",
            Style      => "PerlModule",
            URIs       => "<%CPAN_URIs%>/M/MS/MSERGEANT/<%DistFileNames%>",
            Requires   => "libxml2",
            Actions    => [
                {
                    Phase  => "unpack",
                    Action => "RunCmd",
                    CmdLine =>
$^X . q( -i.bak -ne '$i += /^sub MY::install/; print unless $i == 1; $i += /^}/ if $i; ' Makefile.PL),
                    Comment =>
                        "Preventing XML::LibXML from trying to update ParserDetails.ini",
                },
            ],
        },
        {
            Name       => "XML::LibXSLT",
            Version    => "1.31",
            Style      => "PerlModule",
            URIs       => "<%CPAN_URIs%>/M/MS/MSERGEANT/<%DistFileNames%>",
            Requires   => "libxslt",
            Actions    => [
                {
                    Phase  => "unpack",
                    Action => "RunCmd",
                    CmdLine =>
$^X . q( -i.bak -ne '$i += /^require XML::LibXML/; print unless $i == 1; $i =0 if $i && /^}/; ' Makefile.PL),
                    Comment => "Keeping XML::LibXSLT from blowing up",

                },
            ],
        },
#        {
#            Name         => "XML::Parser",
#            Version      => "2.30",
#            Style        => "PerlModule",
#            URIs         => "<%CPAN_URIs%>/C/CO/COOPERCL/<%DistFileNames%>",
#            Requires     => "expat",
#            DistBaseName => "<%DistName%>.<%Version%>",
#            BuildDir     => "<%BuildRoot%>/<%DistName%>-<%Version%>",
#            ConfigParms => {
#                EXPATLIBPATH    => "<%Prefix%>/lib",
#                EXPATINCPATH    => "<%Prefix%>/include",
#                PREFIX          => "<%Prefix%>",
#                INSTALLSITELIB  => "<%Prefix%>/lib",
#                INSTALLSITEARCH => "<%Prefix%>/lib",
#            },
#            Actions => [
#                {
#                    Action => "DeleteFile",
#                    Phase  => "unpack",
#                    Path   => "t/encoding.t",
#                    Comment => "Fails on my FreeBSD 4.1 box, don't know why",
#                },
#                {
#                    Action => "DeleteFile",
#                    Phase  => "unpack",
#                    Path   => "t/parament.t",
#                    Comment => "Fails on my FreeBSD 4.1 box, don't know why",
#                },
#            ],
#        },
        {
            Name         => "XML::Parser",
            Version      => "2.27",
            Style        => "PerlModule",
            URIs         => "<%CPAN_URIs%>/C/CO/COOPERCL/<%DistFileNames%>",
        },
        {
            Name       => "AxKitDemo",
            IsVirtual  => 1, ## Not a real package
            Version    => 1, ## Still need this
            Requires   => [qw(
                XML::LibXSLT
                XML::LibXML
                AxKit::XSP::ESQL
                DBD::CSV
                AxKit
            )],
            Actions => [
                {
                    Phase  => "install",
                    Action => "WriteFile",
                    Path   => "<%Prefix%>/startup.pl",
                    Body   => <<STARTUP_PL_END,
use lib qw( <%Prefix%>/lib );

1;
STARTUP_PL_END
                },
                {
                    Phase              => "install",
                    Action             => "RunCmd",
                    CmdLine            =>
$^X . q( -i.bak -pe 's/\d+/1/ if /^(M..Spare|Start)Servers/' <%Prefix%>/conf/httpd.conf ),
                    Comment => "Run only 1 server process",

                },
                {
                    Phase              => "install",
                    Action             => "AppendToFile",
                    IfNotAlreadyInFile => 1,
                    Path               => "<%Prefix%>/conf/httpd.conf",
                    Body => <<HTTPD_CONF_END
##
## Init the httpd to use our "private install" libraries
##
PerlRequire startup.pl

##
## AxKit Configuration
##
PerlModule AxKit

<Directory "<%Prefix%>/htdocs">
    Options -All +Indexes +FollowSymLinks

    # Tell mod_dir to translate / to /index.xml or /index.xsp
    DirectoryIndex index.xml index.xsp
    AddHandler axkit .xml .xsp

    AxDebugLevel 10

    AxGzipOutput On

    AxAddXSPTaglib AxKit::XSP::Util

    AxAddStyleMap application/x-xsp \\
                  Apache::AxKit::Language::XSP
</Directory>
HTTPD_CONF_END
                },
                {
                    Phase  => "install",
                    Action => "WriteFile",
                    Path   => "<%Prefix%>/htdocs/index.xsp",
                    Body   => <<INDEX_XML_END,
<?xml-stylesheet href="NULL" type="application/x-xsp"?>
<xsp:page
    xmlns:xsp="http://www.apache.org/1999/XSP/Core"
    xmlns:util="http://apache.org/xsp/util/v1"
>
  <html>
    <body>
      <p>Hi! It's <util:time format="%H:%M:%S"/>.</p>
    </body>
  </html>
</xsp:page>
INDEX_XML_END
                },
            ],
        },
    ],
);

## Actions should default to pre-configure, since the most common action
## is to patch the config, I assume.

## End configuration

###############################################################################

##
## NOTE: This is all in one huge file so it can be used as an install
## script easily.  I'd never admit that it's easier to maintain this
## way, no sir.
##


my $from_scratch = 0;
my $tracing = 0;
my $quiet   = 0;

########################################
##
## Support routines
##
package Installer::Thingy;
use Data::Dumper ();
use Carp ();

sub empty {
    return ! grep defined $_ && length $_, @_;
}

sub new {
    my $proto = shift;
    my $class = ref $proto || $proto;

    my $self = bless {}, $class;

    %$self = (
        ! ( @_ == 1 && ref $_[0] ) ? @_
            : ref $_[0] eq "HASH"  ? %{shift()}
            : ref $_[0] eq "ARRAY" ? ( Data => shift )
            : $self->_fail( "Illegal initializer $_[0]")
    );

    return $self;
}

sub _set_defaults {
    my $self = shift;
    my $defaults = @_ == 1 && ref $_[0] ? shift : { @_ };

    for ( keys %$defaults ) {
        next if defined $self->{$_};
        $self->{$_} = $defaults->{$_};
    }
}


sub _os {
    my $self = shift;

    my $os = $self->{_OSDriver};
    $os = $self->{_Container}->_os
        if !$os && $self->{_Container};
    $self->_fail( ": no OSDriver") unless $os;
    $os->_set_caller( $self );
    return $os;
}

sub _field_display_position {
    my $self = shift;
    return 2_000_000 if $_[0] eq "Actions";
    return 2_000_000 if $_[0] eq "Body";
    return 1_000_000;
} 

sub _sort_field_names_for_display {
    my $self = shift;

    my %seen;
    my %cache;

    return sort {
        ( $cache{$a} ||= $self->_field_display_position( $a ) )
        <=>
        ( $cache{$b} ||= $self->_field_display_position( $b ) )
        ||
        lc $a cmp lc $b
    } grep ! $seen{$_}++, @_;
}


sub _field_names {
    my $self = shift;
    return $self->_sort_field_names_for_display(
        grep index( $_, "_" ), ( @_, keys %$self )
    );
}


sub _is_list_field { my $self = shift; return 0; }

sub _all_field_names {
    my $self = shift;
    return $self->_sort_field_names_for_display( @_, keys %$self )
}


sub _id {
    my $self = shift;
    my @id;

    push @id, $self->{Name}
        if     exists  $self->{Name}
            && defined $self->{Name}
            && length  $self->{Name};

    if ( $tracing > 1 || ! @id ) {
        unshift @id, ref $self;
    }

    return join " ", @id;
}


sub _fail_msg {
    my $self = shift;
#    my $dump = $self->dump;
#    $dump =~ s/^/    /gm;

    my $id = $self->_id;
    my $msg = join "", map
        ref $_ 
            ? UNIVERSAL::can( $_, "description_as_string" )
                ? $_->description_as_string
                : $self->_dump( "", $_, { ExpandMacros => 0 } )
            : $_,
        @_;
    chomp $msg;
    return "$msg\n" if !index $msg, $id;
    $id .= " " if $msg =~ /^\w/;

    return "$id$msg\n";#, $dump, 
}


sub _fail {
    my $self = shift;
    print STDERR $self->_fail_msg( "EXCEPTION: ", @_ )
        if $tracing >= 9;

    $tracing > 1
        ? Carp::confess( $self->_fail_msg( @_ ) )
        : die(           $self->_fail_msg( @_ ) );
}


sub _confess {
    my $self = shift;
    Carp::confess( $self->_fail_msg( @_ ) );
}


sub _log_cmd { shift->_log( "\$ ", @_ ) }


sub _log {
    my $self = shift;
    my $indent_level = 0;

    if ( $tracing > 1 ) {
        my $stack_depth = 0;
        my @foo;

        while ( @foo = caller( $stack_depth ) ) {
            ++$stack_depth;
            ++$indent_level
        }
    }

    print STDERR " " x ( $indent_level - 2 ), $self->_fail_msg( @_ );
}

## TODO: make expand_macros recursive and let it handle CODE, HASH, and ARRAY
## parms.
## TODO: make expand_macros check for use of a list macro inside a non-list
## macro.
sub _expand_macros {
    my $self = shift;
    my ( $name, $value, $options ) = @_;

    return "<DUPLICATE REFERENCE $value>"
        if ref $value && $self->{_ExpandSeen}->{int $value}++;

    $self->_fail( "$name is declared but not defined" )
        unless defined $value;

    my $type = ref $value;

    if ( $type eq "CODE" ) {
        $value = $value->( $self, $name, $options );
        $self->_fail( "$name->(...) returned an undefined value" )
            unless defined $value;
        $type = ref $value;
    }

    return $value
        if defined $options->{ExpandMacros} && ! $options->{ExpandMacros};

    ## Don't bother doing this check if the user requests no macro expansion,
    ## that way references can be pulled out untouched in to scalars
    ## by turning of expansion.
    my $is_list_macro = $self->_is_list_field( $name );
    $self->_confess( "list field $name requested in scalar context" )
        if ! $options->{_DontCheckContext}
            && $options->{Flatten}
            && $is_list_macro
            && defined wantarray
            && ! wantarray;

    if ( ! $type && $is_list_macro ) {
        ## TODO: Allow list sep option, comma would be handy, and
        ## colon and semicolon would be handy for PATH variables.
        $value = [ split /\s+/, $value ];
        shift @$value while @$value && ! length $value->[0];
        if ( @$value > 1 ) {
            $type = "ARRAY";
        }
        else {
            $value = @$value ? $value->[0] : ""
        }
    }

    if ( ! $type ) {
        my %seen;

        my @errors;
        my %macros;
        {
            ## Do this destructively so we can look for extra macro tags
            ( my $v = $value ) =~ s{<%(.*?)%>}{
                $macros{$1} = undef;
                ## Maintain position and also make sure that "<<%Foo%>%"
                ## doesn't cause an error.
                " " x ( 4 + length $1 );
            }ge;
            if ( 0 <= ( my $pos = index $v, "<%" ) ) {
                push @errors, "unmatched '<%' at character ", $pos + 1;
            }
            if ( 0 <= ( my $pos = index $v, "%>" ) ) {
                push @errors, "unmatched '%>' at character ", $pos + 1;
            }
        }


        my %values;

        my $macro_options = {
            $is_list_macro ? () : ( Flatten => 1 ),
        };

        for my $macro ( sort keys %macros ) {
#            push @errors, "List macro <%$macro%> used in non-list macro"
#                unless $is_list_macro || ! $self->_is_list_field( $macro );

            unless (
                eval { $values{$macro} = [ $self->$macro( $macro_options ) ] }
            ) {
                push @errors, $@
                    unless $@ =~ /Can't locate object method/;

                push @errors, "has an unknown macro <%$macro%>";
            }
            elsif( grep !defined, @{$values{$macro}} ) {
                push @errors, "has an undefined value for <%$macro%>";
            }

            $values{$macro} = [ join " ", @{$values{$macro}} ]
                unless $is_list_macro;
        }

        ## This next bit of loopiness expands the string in to 0 or more
        ## strings by interpolating each value of each macro, resulting
        ## in something like a dot product; two macros, one with two
        ## values and one with three, will result in 6 strings.
        my @results = ( $value );

        for my $macro ( keys %values ) {
            my @strings = @results;
            @results = ();
            for my $string ( @strings ) {
                for my $value ( @{$values{$macro}} ) {
                    $self->_log( "$macro => $value in '$string'" )
                        if $tracing > 10;
                    push @results, $string;
                    $results[-1] =~ s/<%\s*$macro\s*%>/$value/gi;
                }
            }
        }

        if ( @errors ) {
            $self->_fail(
                "Errors encountered in $name => '$value':",
                map { s/^/^    /mg; chomp; "$_\n" } @errors
            ) if @errors > 1;

            $self->_fail( $errors[0], " in $name => '$value'" );
        }

        $self->_log( "Macro expansion failed for @_" )
            if ! @results && $tracing;

        return wantarray ? @results : join " ", @results;
    }
    ## TODO: may need an expansion context passed in to expand_macros;
    ## or maybe we should let a subobject expand macros if it can.
    elsif ( UNIVERSAL::isa( $value, "HASH" ) ) {
        local $options->{_DontCheckContext} = 1;
        $value = {
            map {
                index( $_, "_" ) == 0
                    ? () # starts with "_"
                    : ( $_ =>
                       scalar $self->expand_macros( $_, $value->{$_}, $options )
                    );
            } keys %$value
        };

        return $value if defined $options->{Flatten} && ! $options->{Flatten};

        $value = [ map "$_=$value->{$_}", sort keys %$value ];

        return wantarray ? @$value : join " ", @$value;
    }
    elsif ( UNIVERSAL::isa( $value, "ARRAY" ) ) {
        $value = [ map $self->expand_macros( $name, $_, $options ), @$value ];

        return $value if defined $options->{Flatten} && ! $options->{Flatten};

        return wantarray ? @$value : join " ", @$value;
    }

    return "<Can't expand $value>";
}


sub expand_macros {
    my $self = shift;

    ## There should be no loops, but just in case...
    $self->{_ExpandSeen} = ();
    $self->_expand_macros( @_ );
}


sub AUTOLOAD {
    my $self = shift;

    use vars qw( $AUTOLOAD );
    $AUTOLOAD =~ s/.*://;

    my $fc = substr $AUTOLOAD, 0, 1;
    if ( $fc eq uc $fc && $AUTOLOAD =~ /[a-z0-9]/ ) {
        ## Looks like StudlyCaps
        my $sub = $self->can( "_get" );
        if ( $sub ) {
            unshift @_, $self, $AUTOLOAD;
            goto &$sub;
        }
    }

    Carp::confess "Can't locate object method $AUTOLOAD for class ",
        ref $self || $self, "\n"
        if $AUTOLOAD =~ /[a-z0-9]/;
}

sub DESTROY {};


## This is used to implement data "inheritance" from the Installer
## a CODE ref should C<return []> to return an empty list and
## C<return \@v> to prevent macro expansion.  Calling $_[0]->inherit( $name )
## provides access to data inheritence.
sub inherit { 
    my $self = shift;

    return unless exists $self->{_Container} && $self->{_Container};
    Carp::confess if $self == $self->{_Container};

    my $sub = $self->{_Container}->can( "_get" );
    return unless $sub;

    unshift @_, $self->{_Container};
    goto &$sub;
}


sub _flatten_ISA {
    my $class = shift;
    no strict "refs";

    my @ISA = do {
        no strict "refs";
        @{"${class}::ISA"};
    };
    
    return ( $class, map _flatten_ISA( $_ ), @ISA );
}


sub _get_class_macro {
    my $self = shift;
    my ( $macro_context, $name, $options ) = @_;

    my $installer = $self;
    $installer = $installer->{_Container}
        while exists $installer->{_Container} && $installer->{_Container};

    my $classes = $installer->{Classes};

    return unless $classes;

    for ( _flatten_ISA ref $self ) {
        return $macro_context->expand_macros(
            $name, $classes->{$_}->{$name}, $options
        ) if exists $classes->{$_} && exists $classes->{$_}->{$name};
    }

    return ();
}


sub _get_with_inheritance {
    my $self = shift;
    my ( $macro_context, $name, $options ) = @_;

    return $macro_context->expand_macros( $name, $self->{$name}, $options )
        if exists $self->{$name};

    my @v = $self->_get_class_macro( @_ );
    return @v if @v;

    return unless exists $self->{_Container} && $self->{_Container};
    Carp::confess if $self == $self->{_Container};

    my $sub = $self->{_Container}->can( "_get_with_inheritance" );
    unshift @_, $self->{_Container};
    goto &$sub;
}


use vars qw( $_in_get );
sub _get {
    my $self = shift;
    my ( $name, $options ) = @_;

    $options ||= {};

    $self->_fail(
        $name,
        " is a list macro but was requested in a scalar context at ",
        (caller)[1],
        ", line ", 
        (caller)[2],
    )
        if $self->_is_list_field( $name ) && wantarray && ! wantarray;

    $self->_log( "getting $name at ",
        (caller)[1],
        ", line ", 
        (caller)[2],
    ) if $tracing >= 11;

    my @v = do {
        local $_in_get = 1;
        $self->_get_with_inheritance( $self, $name, $options );
    };

    $self->_log(
        "got $name => (",
        join( ", ", map defined $_ ? "'$_'" : "undef", @v ),
        ")"
    ) if $tracing >= 11 || ( $tracing >= 10 && ! $_in_get );

    return wantarray ? @v : $v[0];
}


sub _dump {
    my $self = shift;
    my ( $name, $v, $options ) = @_;

    my $comma = $options->{_Comma} || "";

    return "undef$comma" unless defined $v;

    my $dont_expand_more;
    unless ( ref $v ) {
        local $options->{Flatten} = 0;
        $v = ( $options->{_MacroContext} || $self )->expand_macros(
            $name,
            $v,
            $options
        );
        unless ( ref $v ) {
            if ( 
                0 <= index( $v, "\n" )
                && rindex( $v, "\n" ) eq length( $v ) -1
            ) {
                my $TERM = $name;
#                $TERM = $options->{_NextLabel} unless defined $TERM;
                $TERM = "STRING" unless defined $TERM;
                $TERM = "\U${TERM}_END";
                chomp $comma;
                $TERM =~ s/\W+//;
                while ( 0 <= index $v, $TERM ) {
                    $TERM =~ s{$|_\d+$}{
                        "_" . ( ( $1 || -1 ) + 1 );
                    }e
                }
                return "<<'$TERM'$comma\n$v$TERM\n";
            }
            $v =~ s/([\\'])/\\$1/g;
            return "'$v'$comma";
        }

        ## We just expanded these if they needed expansion.  We want to
        ## dump the structure without reexpanding, in case there was
        ## a "<%" in a macro value.  Plus, why spend the CPU time?
        $dont_expand_more = 1;
    }

    local $options->{ExpandMacros} = 0 if $dont_expand_more;

    return "<LOOP REFERENCE>$comma" if $self->{_DumpSeen}->{int $v}++;

    local $options->{Indent} = "  " unless defined $options->{Indent};
    my $open_indent = $options->{_OpenIndent} || "";
    my $cur_indent  = $options->{_CurIndent} || "";
    my $next_indent = $cur_indent . $options->{Indent};
    local $options->{_CurIndent} = $next_indent;
#    local $options->{_Label} = $options->{_NextLabel};
#    local $options->{_NextLabel} = undef;

    local $options->{_MacroContext} = $v
        if UNIVERSAL::isa( $v, "Installer::Thingy" );

    if ( UNIVERSAL::isa( $v, "HASH" ) ) {
        my @keys = UNIVERSAL::can( $v, "_field_names" )
            ? $v->_field_names
            : sort keys %$v;

        @keys = grep index( $_, "_" ), @keys
            unless $options->{ShowPrivate};

        ## The _Comma hack lets us do <<'FOO', correctly,

        local $options->{_Comma} = @keys < 1 ? "" : ",\n";

        my @values = map {
#            local $options->{_Label} = $_;
#            local $options->{_NextLabel} = $_;
            my $elt_v;

            if ( UNIVERSAL::can( $v, "_get" ) ) {
                my @v = $v->_get( $_, $options );
                $elt_v =
                      @v == 0                ? "undef$comma"
                    : ( @v == 1 && ! ref $v[0] ) ? "'$v[0]'$comma"
                    :                        $self->_dump( $_=>\@v, $options );
            }
            else {
                $elt_v = $self->_dump( $_ => $v->{$_}, $options );
            }
            $elt_v = undef if !index $elt_v, "undef";

            ## undef the key if the value is undefined.
            $_ = undef unless defined $elt_v;
            defined $elt_v ? $elt_v : ();
        } @keys;

        @keys = grep defined, @keys;

        my $max_key_width         = 0;
        my $next_to_max_key_width = 0;
        my %keys;
        for my $key ( @keys ) {
            my $k = $key;
            $k =~ s/([\\'])/\\$1/g;
            $k = "'$k'" if $k =~ /\W/;
            $keys{$key} = $k;
            if ( length $k >= $max_key_width ) {
                $next_to_max_key_width = $max_key_width;
                $max_key_width = length $k;
            }
            elsif ( length $k >= $next_to_max_key_width ) {
                $next_to_max_key_width = length $k;
            }
        }

        my $key_width = $max_key_width > ( $next_to_max_key_width + 2 ) * 1.10
            ? $next_to_max_key_width
            : $max_key_width;

        my $fmt = "%-${key_width}s => %s";
        $fmt = "$next_indent$fmt";
        my $fmt2 = "$next_indent%s => %s";

        return join( "",
            $open_indent,
            "{\n",
            map( sprintf( $fmt, $keys{$_}, shift @values ), @keys ),
            $cur_indent,
            "}",
            $comma,
        );
    }

    if ( UNIVERSAL::isa( $v, "ARRAY" ) ) {
        return "[]$comma" unless @$v;

#        local $options->{_NextLabel} = undef;
        local $options->{_OpenIndent} = $next_indent;
        local $options->{_Comma} = ",\n";

        return join( "",
            $open_indent,
            "[\n",
            map(
                $next_indent . $self->_dump( $name => $_, $options ),
                @$v
            ),
            $cur_indent,
            "]",
            $comma,
        );
    }

    return "$v$comma";
}


sub description_as_string {
    my $self = shift;
    my ( $options ) = @_;

    local $self->{_DumpSeen} = {};
    local $options->{_Comma} = ",\n";
    local $options->{ExpandMacros} = 0 unless defined $options->{ExpandMacros};
    return $self->_dump( ref $self => $self, $options );
}


###############################################################################
package OSDriver;

use Cwd ();

@OSDriver::ISA = qw( Installer::Thingy );


sub _set_caller {
    my $self = shift;
    $self->{Caller} = shift;
}


sub _get_caller { shift->{Caller} }


sub _id {
    my $self = shift;
    my $c = $self->_get_caller;
    return $c ? $c->_id( @_ ) : $self->SUPER::_id( @_ );
}


sub _fail_errno {
    my $self = shift;
    $self->_fail( ": ", $! ) unless @_;
    $self->_fail( ": $!", @_ ? ( " while ", @_ ) : () );
}


sub _get_saved_original_location {
    my $self = shift;
    my ( $fn ) = @_;

    ## This should work on most filesystems, I hope.
    my ( $work_vol, $work_dirs, undef ) =
        File::Spec->splitpath( $self->OriginalsPath );
    my ( $file_vol, $file_dirs, $file_fn ) =
        File::Spec->splitpath( $fn );

    my $save_fn = File::Spec->catpath(
         $work_vol,
         File::Spec->catdirs( $work_dirs, $file_dirs ),
         $file_fn
    );

    return $save_fn;
}


sub _get_saved_original_meta_location {
    my $self = shift;
    my ( $fn ) = @_;

    ## This should work on most filesystems, I hope.
    my ( $work_vol, $work_dirs, undef ) =
        File::Spec->splitpath( $self->MetaInfoDir );
    my ( $file_vol, $file_dirs, $file_fn ) =
        File::Spec->splitpath( $fn );

    ## This is not foolproof due to pathlength limitations.  But it
    ## should suffice for now; I *don't* want to mess with hashing
    ## the filename for now, it makes it too hard to debug.
    my $save_fn = File::Spec->catpath(
        $work_vol,
        File::Spec->catdir( $work_dirs, $file_dirs ),
        $file_fn
    );

    return $save_fn;
}


sub copy_file {
    my $self = shift;
    my ( $from_fn, $to_fn ) = @_;

    $self->mkparentpath( $to_fn );

    $self->_log_cmd( "cp '$from_fn' '$to_fn'" );
    File::Copy::copy( $from_fn, $to_fn );

    my @stats = stat $from_fn;

    ## TODO: test and cope with symlinks
}


sub store_perldata {
    my $self = shift;
    my ( $fn, $structure ) = @_;

    $self->mkparentpath( $fn );

    open FH, ">$fn"              or $self->_fail_errno( $fn );
    local $Data::Dumper::Indent;
    local $Data::Dumper::Quotekeys;
    local $Data::Dumper::Terse;
    $Data::Dumper::Indent = 1;
    $Data::Dumper::Quotekeys = 0;
    $Data::Dumper::Terse = 1;

    print FH Dumper( $structure ) or $self->_fail_errno( $fn );
    close FH                      or $self->_fail_errno( $fn );
}


sub read_perldata {
    my $self = shift;
    my ( $fn ) = @_;

    ## make it absolute to prevent @INC searching.
    $fn = File::Spec->rel2abs( $fn, $self->WorkDir )
        unless File::Spec->filename_is_absolute( $fn );

    my $v = do $fn;

    if ( ! defined $v ) {
        $self->_fail_errno( $fn ) if $!;
        $self->_fail( "$@: $fn" ) if $@;
    }
    return $v;
}


sub save_original_file {
    my $self = shift;
    my ( $path ) = @_;
    my $saved_path = $self->_get_saved_original_location( $path );

    ## Never overwrite a previously saved file.  I'd like install() to
    ## should detect these and delete them, somehow, so a reconfigured
    ## install works.  Not sure how, unless we store a state file in
    ## the workdir.
    ## Hmmm, that's not a bad plan.
    return if -e $saved_path;

    $self->_copy_file( $path, $saved_path );

    my @stats = stat $path;

    my $meta = {
        Path      => $path,
        SavedPath => $saved_path,
        mode      => $stats[0],
        uid       => $stats[4],
        gid       => $stats[5],
        atime     => $stats[8],
        mtime     => $stats[9],
    };

    $self->_store_perldata(
        $self->_get_saved_original_meta_info_location( $path ),
        $meta,
    );
}


sub chmod {
    my $self = shift;
    my ( $perms, $path ) = @_;

    my $show_perms = $perms =~ /^[0-9]+\z/
        ? _as_octal( $perms )
        : $perms;

    $self->_log_cmd(
        "chmod $show_perms $path # ",
        $self->_perms_to_letters( $perms )
    );
    CORE::chmod $perms, $path
        or $self->_fail_errno( $path );
}


sub escape_command_line_parameter {
    my $self = shift;

    for ( shift ) {
        return qq{"$_"} if m{[^\w=/\\+-]};
        return $_;
    }
}


sub getgrnam {
    my $self = shift;
    my ( $gname ) = @_;

    return CORE::getgrnam $gname
        or $self->_fail_errno( "looking up group name for $gname");
}


sub getgrgid {
    my $self = shift;
    my ( $gid ) = @_;

    return CORE::getgrgid $gid
        or $self->_fail_errno( "looking up group id for $gid");
}


sub getpwnam {
    my $self = shift;
    my ( $uname ) = @_;

    return CORE::getpwnam $uname
        or $self->_fail_errno( "looking up user $uname");
}


sub getpwuid {
    my $self = shift;
    my ( $uid ) = @_;

    return CORE::getpwuid $uid
        or $self->_fail_errno( "looking up user $uid");
}


sub chown {
    my $self = shift;
    my ( $uid, $gid, $path ) = @_;

    my $gname;
    
    if ( $gid =~ /^\d+$/ ) {
        $gname = $self->getgrnam( $gid );
    }
    else {
        $gname = $gid;
        $gid = $self->getgrgid( $gname );
    }

    my $uname;

    if ( $uid =~ /^\d+$/ ) {
        $uname = $self->getgrnam( $uid );
    }
    else {
        $uname = $uid;
        $uid = $self->getgrgid( $uname );
    }

    $self->_log_cmd( "chown $gname:$uname  # ($gid:$uid)" ) ;
    CORE::chown $uid, $gid, $path
        or $self->_fail_errno( $path );
}


sub _iso8601_localtime {
    my $self = shift;

    my @times = localtime @_;

    $times[5] += 1900;
    $times[4] += 1;

    ## TODO: add the timezone indicator
    return sprintf( "%04d/%02d/%02d-%02d:%02d:%02d", reverse @times[0..5] );
}


sub _perms_to_letters {
    my $self = shift;

    ## TODO: letterify sticky, etc.
    my @letters = reverse split //, "rwxrwxrwx";
    my @bits    = reverse split //, sprintf( "%09b", shift );
    return join "", reverse map {
        my $l = shift @letters;
        $_ ? $l : "-";
    } @bits;
}


sub _as_octal { sprintf "0%o", shift }


BEGIN { $ENV{PWD} = Cwd::cwd() }
sub cd {
    my $self = shift;
    my $name = shift if @_ > 1;
    my ( $dir ) = @_;

    my $cmt = defined $name ? "   # ($name)" : "";

    ## We only output the result if it looks different from where
    ## we think we are.
    $self->_log_cmd( "cd $dir$cmt" ) if $dir ne $ENV{PWD};

    ## We always do the syscall in case someone else called CORE::cd.
    chdir $dir or die $self->_fail_errno( "cding to $dir$cmt" );

    $ENV{PWD} = $dir;
}


sub utime {
    my $self = shift;
    my ( $atime, $utime, $path ) = @_;

    my $atime_str;
    if ( $atime =~ /^\d+\z/ ) {
        $atime_str = $self->_iso8601_localtime( $atime );
    }
    else {
        $atime_str = $atime;
    }

    my $utime_str;
    if ( $utime =~ /^\d+\z/ ) {
        $utime_str = $self->_iso8601_localtime( $utime );
    }
    else {
        $utime_str = $utime;
    }

    $self->_log_cmd( "touch -t $atime_str --time=access $path" ) ;
    $self->_log_cmd( "touch -t $utime_str $path" ) ;
    CORE::utime $atime, $utime, $path
        or $self->_fail_errno( $path );
}


sub touch {
    my $self = shift;
    my ( $path ) = @_;

    return $self->utime( (scalar time) x 2, $path )
        if -e $path;

    $self->mkparentpath( $path );
    open F, ">$path" or $self->_fail_errno( "creating '$path'" );
    close F          or $self->_fail_errno( "closing '$path' after creation" );
}


sub mtime {
    my $self = shift;
    my ( $path ) = @_;

    my $t = (stat $path)[9];
    return defined $t ? $t : -1;
}


sub restore_file {
    my $self = shift;
    my ( $path ) = @_;

    my $saved_path = $self->_get_saved_original_location( $path );

    $self->_fail( "saved copy of original not found: $saved_path" )
        unless -e $saved_path;

    my $meta = $self->read_perldata(
        $self->_get_saved_original_meta_info_location( $path )
    );

    $self->_copy_file( $saved_path, $path );

    $self->utime( $meta->{atime}, $meta->{mtime}, $path );
    $self->chmod( $meta->{mode}, $path );
    $self->chown( $meta->{gid}, $meta->{uid}, $path );
}


sub rm {
    my $self = shift;
    my ( $path ) = @_;

    if ( -e $path ) {
        $self->_log_cmd( "rm $path" );
        unlink $path or $self->_fail_errno( "deleting $path" );
    }
}


sub rmtree {
    my $self = shift;
    my ( $path ) = @_;

    if ( -e $path ) {
        $self->_log_cmd( "rm -rf $path" );
        File::Path::rmtree( [$path] );
    }
}


sub mkpath {
    my $self = shift;
    my ( $path, $perms ) = @_;
    unless ( -d $path ) {
        $self->_log_cmd( "mkdir -p $path" );
        $perms = 0755 unless defined $perms;
        $self->_log( " WARNING: Creating $path with 0 perms!" )
            unless $perms;
        my $show_perms = $perms =~ /^[\d+]/
            ? _as_octal( $perms )
            : $perms;
        $self->_log_cmd(
            "chmod $show_perms $path    # ", $self->_perms_to_letters( $perms )
        );
        File::Path::mkpath( [$path], $tracing > 2, $perms );
    }
}


sub mkparentpath {
    my $self = shift;
    my ( $path, $perms ) = @_;
    my ( undef, $dir ) = File::Basename::fileparse( $path );
    $self->mkpath( $dir );
}


sub read_file {
    my $self = shift;
    my $path = shift;
    my $body;

    open  F, "<$path"        or $self->_fail_errno( "opening $path for read" );
    read  F, $body, -s $path or $self->_fail_errno( "reading from $path" );
    close F                  or $self->_fail_errno( "closing $path" );

    return $body;
}


sub write_file {
    my $self = shift;
    my $path = shift;
    my $perms = shift;

    $perms ||= 0700;
    ## TODO: autobinmode by looking at $body

    $self->_log_cmd( "install $path" );

    open  F, ">$path" or $self->_fail_errno( "opening $path for write" );
    print F @_        or $self->_fail_errno( "writing to $path" );
    close F           or $self->_fail_errno( "closing $path" );
    
    $self->chmod( $perms, $path );
}


sub append_to_file {
    my $self = shift;
    my $path = shift;

    $self->_log_cmd( "install >>$path" );

    ## TODO: autobinmode by looking at the file
    open  F, ">>$path" or $self->_fail_errno( "opening $path for append" );
    print F @_         or $self->_fail_errno( "writing to $path" );
    close F            or $self->_fail_errno( "closing $path" );
}


sub run {
    my $self = shift;
    my ( @cmd ) = @_;

    @cmd = map {
        my $c = $_;

        $c = $c->( $self->_caller || $self ) if ref $c eq "CODE";

          ref $c eq "ARRAY"   ? @$c
        : ref $c eq "HASH"    ? map "$_=$c->{$_}", sort keys %$c
                              : $c
    } @cmd;

    my $cmd = join " ", @cmd;
    $self->_log_cmd( $cmd );
    my $r = system @cmd;
    $self->_fail( ": couldn't run `$cmd`")
        if ! defined $r || $r < 0;
    $self->_fail( ": nonzero return from `$cmd`: ", $r >> 8 )
        if $r;
}


sub run_and_capture_stdout {
    my $self = shift;
    my ( @cmd ) = @_;

    my $cmd = join " ", @cmd;
    $self->_log_cmd( $cmd );
    my $stdout = `$cmd`;
    $self->_fail_errno( ": running `$cmd`")
        unless defined $stdout;
    $self->_fail( ": `$cmd` returned ", $? >> 8 )
        if $?;
    return $stdout;
}


###############################################################################
package Action;

@Action::ISA = qw( Installer::Thingy );

sub new {
    my $proto = shift;
    my $action= { ref $_[0] ? %{shift()} : @_ };

    my $action_type;
    my $real_proto = $proto;

    if ( exists $action->{Action} && defined $action->{Action} ) {
        $action_type = ref $action->{Action} || $action->{Action};
        $real_proto .= "::$action_type";
    }

    my $found = UNIVERSAL::isa( $real_proto, "Installer::Thingy" );
    $real_proto = $proto unless $found;
    
    my $self = bless $action, $real_proto;

    $self->_init;

    $self->{_Container}->_fail( ": Action field missing")
        unless exists $self->{Action} ;

    $self->{_Container}->_fail( ": Action field undefined")
        unless defined $self->{Action} ;

    $self->{_Container}->_fail( ": unknown Action type $action->{Action}")
        unless $found;

    return $self;
}


sub _init {}


sub _id {
    my $self = shift;

    return $self->{_Container}->_id if $self->{_Container};
    return $self->SUPER::_id;
}


sub validate {
    my $self = shift;
    
    $self->_fail( ": Missing Phase")
        unless exists $self->{Phase};

    1;
}


## Ass of this writing (so to speak), the main reason for an Action class is to 
## support validation and action dispatching.  Later it will allow mix-ins
## so ppl can concoct their own variants / extensions, like custom pkgs.

########################################
package Action::CODE;

@Action::CODE::ISA = qw( Action );

sub _init {
    my $self = shift;

    ## Hide this off where expand_macros won't trip over it.
    $self->{_CodeRef} = $self->{Action};
    $self->{Action} = "CODE";
}

sub execute {
    my $self = shift;

    $self->_log( "executing Perl code" );

    $self->{_CodeRef}->( $self );
}

########################################
package Action::WriteFile;

@Action::WriteFile::ISA = qw( Action );

sub validate {
    my $self = shift;

    my @errors;

    eval { $self->SUPER::validate } or push @errors, $@;

    push @errors, $self->_fail_msg( ": Missing Path")
        unless exists $self->{Path};

    push @errors, $self->_fail_msg( ": Missing Body")
        unless exists $self->{Body};

    die @errors if @errors;

    1;
}


sub execute {
    my $self = shift;

    $self->_os->write_file( $self->Path, $self->Perms, $self->Body );
}

########################################
package Action::DeleteFile;

@Action::DeleteFile::ISA = qw( Action );

sub validate {
    my $self = shift;

    my @errors;

    eval { $self->SUPER::validate } or push @errors, $@;

    push @errors, $self->_fail_msg( ": Missing Path")
        unless exists $self->{Path};

    die @errors if @errors;

    1;
}


sub execute {
    my $self = shift;
    $self->_os->rm( $self->Path );
}

########################################
package Action::DeleteDir;

@Action::DeleteDir::ISA = qw( Action );

sub validate {
    my $self = shift;

    my @errors;

    eval { $self->SUPER::validate } or push @errors, $@;

    push @errors, $self->_fail_msg( ": Missing Path")
        unless exists $self->{Path};

    die @errors if @errors;

    1;
}


sub execute {
    my $self = shift;
    $self->_os->rmtree( $self->Path );
}

########################################
package Action::AppendToFile;

@Action::AppendToFile::ISA = qw( Action );

sub validate {
    my $self = shift;

    my @errors;

    eval { $self->SUPER::validate } or push @errors, $@;

    push @errors, $self->_fail_msg( ": Missing Path")
        unless exists $self->{Path};

    push @errors, $self->_fail_msg( ": Missing Body")
        unless exists $self->{Body};

    die @errors if @errors;

    1;
}


sub execute {
    my $self = shift;

    my $path = $self->Path;
    my $body = $self->Body;

    if ( $self->IfNotAlreadyInFile
        && 0 <= index $self->_os->read_file( $path ), $body
    ) {
        $self->_log( "already appended to file $path, not again" )
            if $tracing;
        return;
    }

    $self->_os->append_to_file( $path, $body );
}

########################################
package Action::RunCmd;

@Action::RunCmd::ISA = qw( Action );

sub validate {
    my $self = shift;

    my @errors;

    eval { $self->SUPER::validate } or push @errors, $@;

    push @errors, $self->_fail_msg( ": Missing Cmd")
        unless exists $self->{CmdLine};

    die @errors if @errors;

    1;
}


sub execute {
    my $self = shift;

    my $pkg = $self->{_Container};

    $self->_confess( "Action not in Package" )
        unless $pkg->isa( "Package" );

    $pkg->_run_build_cmd( $self->CmdLine );
}

###############################################################################
package Package;

@Package::ISA = qw( Installer::Thingy );

use Carp qw( confess );
use File::Spec;


sub empty {
    return ! grep defined $_ && length $_, @_;
}


sub new_subclass {
    my $proto = shift;
    my $pkg = { ref $_[0] ? %{$_[0]} : @_ };

    my $real_proto = $proto;
    $real_proto .= "::$pkg->{Style}" unless empty $pkg->{Style};

    my $found = UNIVERSAL::isa( $proto, "Installer::Thingy" );
    $real_proto = $proto unless $found;

    Package->new( $pkg )->_fail( "unknown style $pkg->{Style}" )
        unless $found;

    return $real_proto->new( @_ );
}


sub new {
    my $proto = shift;

    my $pkg = { ref $_[0] ? %{shift()} : @_ };
    my $self = bless $pkg, ref $proto || $proto;

    my $actions = delete $self->{Actions};
    my $inherited_actions = $self->Actions( { ExpandMacros => 0 } );

    if ( $inherited_actions ) {
        $self->add_action( $_ ) for @$inherited_actions;
    }

    if ( $actions ) {
        $self->add_action( $_ ) for @$actions;
    }

    return $self;
}


{
    ## In presentation order...
    my @_std_field_names = qw(
        Name
        Style
        Version
        MinVersion
        MaxVersion
        BuildDir
        ConfigParms
        DistName
        DistBaseName
        DistFileNames
        DistFiles
        URIs
        Requires
        ExternalComponents
    );

    my %_list_fields = map { ( $_ => undef ) } qw(
        ConfigParms
        DistFileNames
        DistFiles
        URIs
        Requires
        ExternalComponents
    );

    my $num = 0;
    my %_field_name_order = map {
        ( $_ => $num++ );
    } @_std_field_names;

    sub _field_display_position {
        my $self = shift;
        my ( $name ) = @_;
        return exists $_field_name_order{$name}
            ? $_field_name_order{$name}
            : $self->SUPER::_field_display_position( $name );
    }


    sub _field_names { shift->SUPER::_field_names( @_std_field_names, @_ ) }

    sub _is_list_field {
        my $self = shift;
        my ( $name ) = @_;
        return
            exists $_list_fields{$name} || $self->SUPER::_is_list_field( $name);
    }
}


sub validate {
    my $self = shift;

    my @errors;
    for ( $self->_field_names ) {
        my $ok = eval { [ $self->$_ ] };
        push @errors, $@ unless $ok || $@ =~ /Can't locate object method/;
    }

    if ( $self->{Actions} ) {
        $_->validate for @{$self->{Actions}};
    }

    die @errors if @errors;
}


sub add_action {
    my $self = shift;

    my $action = UNIVERSAL::isa( $_[0], "Action" )
        ? shift
        : Action->new( 
            %{shift()},
            _Container => $self,
        );

    ## Really, we need a whole slew of actions.  Well, *really* we need
    ## a full programming environment.
    push @{$self->{Actions}}, $action;
}


## TODO: Validate things.... (i.e. call this in _get)
sub validate_Version {
    my $self = shift;
    my ( $name, $value ) = @_;
    ## protect against perl vstring madness
    $self->_log( "version number contains non-printables" )
        if $value =~ /[\000-\037]/;
}


sub _get_sentinal_file_name {
    my $self = shift;
    my $action = @_ ? shift : (caller(1))[3];
    
    ## Hmm, we could add a layer of indirection by using a macro that defines
    ## the sentinal macro name, but EOBFUSCATED
    confess "No action passed" unless defined $action && length $action;

    $action =~ s/.*:://;

    my $sentinal_macro_name = "\u${action}SentinalFile";

    my $sentinal_file_name = $self->$sentinal_macro_name;

    if ( ! defined $sentinal_file_name ) {
        ## This is lazy defaulting of a macro.  That's a bit of
        ## a hack, but otherwise I need to be diligent about defining all
        ## action sentinals up front, as do our users.  Perlhaps a "*"
        ## syntax in macro names.
        ##
        ## local won't cut it here because we need to delete() if it is undef,
        ## and autovivification screws that up. So we save it in a temp var.
        my $prev_sm = $self->{$sentinal_macro_name};
        $self->{$sentinal_macro_name} =
            "<%MetaInfoDir%>/<%DistBaseName%>_${action}_done";

        $sentinal_file_name = $self->$sentinal_macro_name;

        if ( defined $prev_sm ) {
            $self->{$sentinal_macro_name} = $prev_sm;
        }
        else {
            delete $self->{$sentinal_macro_name};
        }
    }

    $self->_fail( "couldn't determine the sentinal filename for $action" )
        unless defined $sentinal_file_name;

    return $sentinal_file_name;
}


sub _get_sentinal_file_mtime {
    my $self = shift;
    my $action = @_ ? shift : (caller(1))[3];

    return $self->_os->mtime( $self->_get_sentinal_file_name( $action, @_ ) );
}


sub _touch_sentinal_file {
    my $self = shift;
    my $action = @_ ? shift : (caller(1))[3];
    $self->_os->touch( $self->_get_sentinal_file_name( $action, @_ ) );
}


##
## Actions
##
sub cd_to {
    my $self = shift;
    my ( $name ) = @_;

    my $path = $self->$name;

    $self->_fail(
        " $name not defined at ",
        (caller)[1],
        ", line ",
        (caller)[2]
    ) unless defined $path;

    $self->_os->mkpath( $path );

    $self->_os->cd( $name => $self->$name || $self->_fail( " $name not defined" ) );
}


sub _parse_ver {
    my $self = shift;
    my ( $ver ) = @_;

    # A "seg pair" is a /\d+\D+/, so version numbers like "1a" can be
    # coped with.
    my @seg_pairs = split /[^0-9a-bA-B]/, $ver, -1;
    $self->_fail( "can't parse version number '$ver'" )
        if ! @seg_pairs || grep !length, @seg_pairs;
    pop @seg_pairs while @seg_pairs && !$seg_pairs[-1];
    return map /(\d*)(.*)/, @seg_pairs;
}


sub _cmp_ver {
    my $self = shift;
    my ( $vera, $verb ) = @_;

    my @a_segs = $self->_parse_ver( $vera );
    my @b_segs = $self->_parse_ver( $verb );

    while ( @a_segs && @b_segs ) {
        my ( $a_seg, $b_seg ) = ( shift @a_segs || 0, shift @b_segs || 0 );
        my $a_is_numeric = $a_seg =~ /^(\d+(\.\d+)?|\.\d+)\z/;
        my $b_is_numeric = $b_seg =~ /^(\d+(\.\d+)?|\.\d+)\z/;
        if ( $a_is_numeric && $b_is_numeric ) {
            return $a_seg <=> $b_seg || next;
        }
        elsif ( ! $a_is_numeric && ! $b_is_numeric ) {
            return $a_seg cmp $b_seg || next;
        }
        else {
            $self->_fail( 
                "can't compare incompatible version numbers '$vera' and '$verb'"
            );
        }
    }
    return @a_segs <=> @b_segs;
}


sub _validate_tgz_file {
    my $self = shift;
    my ( $fn ) = @_;

    return 0 unless -e $fn;

    open FH, "<$fn"       or $self->_fail( ": $! opening $fn" );
    my $first_few;
    my $count = read FH, $first_few, 2;
    $self->_fail( ": $! reading $fn") unless defined $count;
    close FH               or $self->_fail( ": $! closing $fn");

    return 0 unless $count >= 2 && unpack( "H4", $first_few ) eq "1f8b";

    ## TODO: Use Compress::Zlib
    return 0 unless eval {
        $self->_run_build_cmd(
            "gunzip -q -c $fn >/dev/null"
        );
        1
    };

    return 1;
}


sub _validate_tar_gz_file { shift->_validate_tgz_file( @_ ) }


sub _validate_tar_file {
    my $self = shift;
    my ( $fn ) = @_;

    return 0 unless -e $fn;

    open FH, "<$fn"       or $self->_fail( ": $! opening $fn" );
    my $first_few;
    my $count = read FH, $first_few, 263;
    $self->_fail( ": $! reading $fn") unless defined $count;
    close FH               or $self->_fail( ": $! closing $fn");

    return 0 unless $count >= 2 && substr( $first_few, -6) eq "ustar\000";

    return 0 unless eval {
        $self->_run_build_cmd( "tar tf $fn >/dev/null" );
        1
    };

    return 1;
}


sub validate_files {
    my $self = shift;

    ## TODO: use File::Type or File::MimeMagic
    grep {
        my $found = -e $_;

        my $is_valid;

        if ( $found ) {
            $is_valid =
              /\.tar\.gz\z/ ? $self->_validate_tar_gz_file( $_ )
            : /\.tgz\z/     ? $self->_validate_tgz_file( $_ )
            : /\.tar\z/     ? $self->_validate_tar_file( $_ )
            : $self->_fail( "can't validate file $_, unknown type" );

            $self->_log( ": $_ ", ! $is_valid ? "not " : (), "valid" )
                if $tracing;
        }
        else {
            $self->_log( ": $_ not found" )
                if $tracing;
        }

        $is_valid;
    } @_;
}


sub validate_or_unlink_files {
    my $self = shift;
    grep {
        my $is_valid = scalar $self->validate_files( $_ );
        $self->_os->rm( $_ ) if !$is_valid && -e $_;
        $is_valid
    } @_;
}


sub _unpack_tar_gz_file {
    my $self = shift;
    my ( $fn ) = @_;
    $self->_run_build_cmd( "gunzip -c $fn | tar xf -" );
}

sub _unpack_tgz_file { shift->_unpack_tar_gz_file( @_ ) }

sub _unpack_tar_file {
    my $self = shift;
    my ( $fn ) = @_;
    $self->_run_build_cmd( "tar xf $fn" );
}


sub unpack_file {
    my $self = shift;

    my ( $fn ) = @_;

    for ( $fn ) {
        unless ( eval {
            /\.tar\.gz\z/ ? $self->_unpack_tar_gz_file( $_ )
            : /\.tgz\z/   ? $self->_unpack_tgz_file( $_ )
            : /\.tar\z/   ? $self->_unpack_tar_file( $_ )
            : $self->_fail( "can't validate file $_, unknown type" );
            1;
        } ) {
            my $x = $@;
            eval {$self->_os->rmtree( $self->BuildDir ) };
            die $x;
        }
    }
}

my $INT_caught = 0;
sub _catch_INT { $INT_caught = 1; }

sub _execute_actions {
    my $self = shift;
    my $action = @_ ? shift : (caller(1))[3];

    $action =~ s/.*://;

    my $actions = $self->Actions( { ExpandMacros => 0 } );

    for ( @$actions ) {
        if ( lc $_->{Phase} eq $action ) {
            $_->{_OSDriver} = $self->_os;
            $self->cd_to( "BuildDir" );
            $_->execute;
            delete $_->{_OSDriver};
        }
    }
}

sub download {
    my $self = shift;

    $self->_log( "checking download" )
        if $tracing;

    if ( $self->IsVirtual ) {
        $self->_execute_actions;
        return;
    }

    $self->_log( "checking DistFiles" )
        if $tracing;

    ## TODO: use LWP or Lib::GHTTP if present.

    my @dist_files = $self->DistFiles;
    my @valid_distfiles = $self->validate_or_unlink_files( @dist_files );
    return @valid_distfiles if @valid_distfiles && ! $self->Force;

    $self->rm( $_ ) for @valid_distfiles;  ## Only here if Force.

    $self->_log( "downloading" )
        if $tracing;

    $self->cd_to( "DistsDir" );

    my @uris = $self->URIs;

    unless ( @uris ) {
        my $dist_files =
            ! @dist_files      ? " or distribution files defined, can't download or build."
            : @dist_files == 1 ? ", please download $dist_files[0] manually."
            : @dist_files == 2 ? ", please download $dist_files[0] or $dist_files[1] manually."
            : ", please download one of " . join( ", ", @dist_files ) . " manually.";
        $self->_fail( ": no URIs defined$dist_files\n", $self );
    }

    for (0..1) {
        for my $uri ( @uris ) {

            ## TODO: use URI; here.
            ## TODO: Have the URIs paired with the distfiles.
            my $name = $uri;
            $name =~ s/[?#].*//;
            ## TODO: check that $name is a valid distfile
            $name = File::Basename::fileparse( $name );
            $self->_fail( "couldn't parse a filename out of '$uri'" )
                unless length $name;
            print $self->_id, "\$ lynx -source $uri > $name\n"
                unless $quiet;
            {
                $INT_caught = 0;
                local $SIG{INT} = \&_catch_INT;
                `lynx -source $uri > $name`;
                $self->_fail( "Exiting by user request" ) if $INT_caught;
            }

            if ( scalar $self->validate_or_unlink_files( $name ) ) {
                $self->_execute_actions;
                $self->_touch_sentinal_file;
                return;
            }
        }
    }

    $self->_fail( "failed to download a DistFile" );
}


sub unpack {
    my $self = shift;

    $self->_log( "checking unpack" )
        if $tracing;

    if ( $self->IsVirtual ) {
        $self->_execute_actions;
        return;
    }

    my $sentinal_mtime = $self->_get_sentinal_file_mtime;

    my $builddir       = $self->BuildDir;
    my $builddir_mtime = $self->_os->mtime( $builddir );

    my $do_it = $builddir_mtime < 0;

    ## TODO: use the newest distfile
    my @distfiles = $self->DistFiles;

    $self->cd_to( "BuildRoot" );

    my $distfile;
    my $distfile_mtime = -1;

    if ( $self->Force ) {
        $self->_log( "unpack forced" );
        $self->_os->rm( $_ ) for @distfiles;
        $do_it = 1;
    }
    else {
        ## See if we can reuse an existing distfile
        for ( @distfiles ) {
            if ( defined ( $distfile = ($self->validate_or_unlink_files( $_ ))[0] ) ) {
                $distfile_mtime = $self->_os->mtime( $_ );
                last;
            }
        }
    }

    $do_it ||=
           $self->FromScratch
        || 0               > $sentinal_mtime
        || 0               > $builddir_mtime
        || $distfile_mtime > $sentinal_mtime
        || $distfile_mtime > $builddir_mtime
        || $self->_get_sentinal_file_mtime( "download" ) > $sentinal_mtime;
    ;

    if ( ! defined $distfile && $do_it ) {
        $self->download;

        $self->cd_to( "BuildRoot" );

        for ( @distfiles ) {
            if ( -f ) {
                $distfile = $_;
                $distfile_mtime = $self->_os->mtime( $_ );
                last;
            }
        }

        $self->_fail(
            "no DistFiles found after download, checked for ",
            join ", ", @distfiles
        ) unless defined $distfile;

        $do_it = 1;
    }


    return unless $do_it;

    $self->_fail(
        "no DistFiles found!!!!",
        join ", ", @distfiles
    ) unless defined $distfile;

    $self->_log( "unpacking" )
        if $tracing;

    ## TODO: allow optional reuse of builddirs
    $self->_os->rmtree( $builddir );

    unless ( eval { $self->unpack_file( $distfile ); 1 } ) {
        my $x = $@;
        $self->_os->rm( $distfile );
        die $x;
    }

    $self->_fail(
        "Unpacking DistFile $distfiles[0] did not create BuildDir ",
        $builddir,
    ) unless -d $builddir ;

    $self->_execute_actions;
    $self->_touch_sentinal_file;
}


sub _run_build_cmd {
    my $self = shift;
    my ( @cmd ) = @_;

    return unless @cmd;

    my $buildenv = $self->BuildEnv( { Flatten => 0 } );

    my %saved_env = %ENV;

    my $ok = eval {
        if ( $buildenv && keys %$buildenv ) {
            ## TODO: join with pathsep for ARRAYs
            $ENV{$_} = $buildenv->{$_}
                for keys %$buildenv;
        }

        $self->_os->run( @cmd );

        1;
    };

    %ENV = %saved_env;

    die $@ unless $ok;
}


sub _run_build_cmd_and_capture_stdout {
    my $self = shift;
    my ( @cmd ) = @_;

    return unless @cmd;

    my $buildenv = $self->BuildEnv( { Flatten => 0 } );

    my %saved_env = %ENV;

    my $stdout = eval {
        if ( $buildenv && keys %$buildenv ) {
            ## TODO: join with pathsep for ARRAYs
            $ENV{$_} = $buildenv->{$_}
                for keys %$buildenv;
        }

        $self->_os->run_and_capture_stdout( @cmd );
    };

    %ENV = %saved_env;

    die $@ unless defined $stdout;

    return $stdout;
}


## default build is for "configure" packages
sub _do_configure {
    my $self = shift;

    $self->_run_build_cmd( $self->ConfigCmd )
        unless -f "Makefile" || -f "makefile";
}



sub configure {
    my $self = shift;

    $self->_log( "checking configure" )
        if $tracing;

    my $do_it;

    my $sentinal_mtime = $self->_get_sentinal_file_mtime;

    {
        my @r = map $self->{_Container}->get_package( $_ ), $self->Requires;

        $self->_log( " Requires: ", join ", ", map $_->Name, @r )
            if $tracing && @r;

        for ( @r ) {
            $_->upgrade;
            $do_it ||= $_->_get_sentinal_file_mtime( "upgrade" )
                       > $sentinal_mtime;
        }

        @r = map
            $self->{_Container}->get_package( $_ ),
            $self->ExternalComponents;

        $self->_log( " ExternalComponents: ", join ", ", map $_->Name, @r )
            if $tracing && @r;

        for ( @r ) {
            ## TODO: restructure the macros so components may be placed in
            ## the package as needed.
            $_->unpack;
            $do_it ||= $_->_get_sentinal_file_mtime( "unpack" )
                       > $sentinal_mtime;
        }
    }

    if ( $self->IsVirtual ) {
        $self->_execute_actions;
        return;
    }

    $self->unpack;

    $do_it ||=
           0                                           > $sentinal_mtime
        || $self->_get_sentinal_file_mtime( "unpack" ) > $sentinal_mtime
        || $self->Force
        || $self->FromScratch;

    return unless $do_it;

    $self->_log( "configuring" )
        if $tracing;

    $self->cd_to( "BuildDir" );

    $self->_do_configure( $self->ConfigParms );

    $self->_execute_actions;
    $self->_touch_sentinal_file;
}


sub make {
    my $self = shift;
    $self->_log( "checking make" )
        if $tracing;

    $self->configure;

    if ( $self->IsVirtual ) {
        $self->_execute_actions;
        return;
    }

    my $do_it;

    my $sentinal_mtime = $self->_get_sentinal_file_mtime;

    {
        my @r = map
            $self->{_Container}->get_package( $_ ),
            $self->DetectedRequires;

        $self->_log( " DetectedRerequires: ", join ", ", map $_->Name, @r )
            if $tracing && @r;

        for ( @r ) {
            $_->upgrade;
            $do_it ||= $_->_get_sentinal_file_mtime( "upgrade" )
                       > $sentinal_mtime;
        }
    }

    $do_it ||= 
           0                                              > $sentinal_mtime
        || $self->_get_sentinal_file_mtime( "configure" ) > $sentinal_mtime
        || $self->Force
        || $self->FromScratch;

    return unless $do_it;

    $self->_log( "making" )
        if $tracing;

    $self->cd_to( "BuildDir" );

## HACK: this test is a known failure in the test suite
## and FreeBSD 4.1's make does not overlook it.
unlink "tests/exslt/sets/has-same-node.1.xsl"
    if -f "tests/exslt/sets/has-same-node.1.xsl";
unlink "tests/exslt/sets/has-same-node.1.xml"
    if -f "tests/exslt/sets/has-same-node.1.xml";

    $self->_run_build_cmd( qw( make ) );

    $self->_execute_actions;
    $self->_touch_sentinal_file;
}


sub _do_test {
    my $self = shift;

    $self->_run_build_cmd( $self->TestCmd );
}


sub test {
    my $self = shift;

    $self->_log( "checking test" )
        if $tracing;

    $self->make;

    if ( $self->IsVirtual ) {
        $self->_execute_actions;
        return;
    }

    my $sentinal_mtime = $self->_get_sentinal_file_mtime;

    my $do_it =
           0                                         > $sentinal_mtime
        || $self->_get_sentinal_file_mtime( "make" ) > $sentinal_mtime
        || $self->Force
        || $self->FromScratch;

    return unless $do_it;

    $self->_log( "testing" )
        if $tracing;

    $self->_do_test;
    $self->_execute_actions;
    $self->_touch_sentinal_file;
}


sub install {
    my $self = shift;

    $self->_log( "checking install" )
        if $tracing;

    $self->test;

    if ( $self->IsVirtual ) {
        $self->_execute_actions;
        return;
    }

    my $sentinal_mtime = $self->_get_sentinal_file_mtime;

    my $do_it =
           0                                          > $sentinal_mtime
        || $self->_get_sentinal_file_mtime( "build" ) > $sentinal_mtime
        || $self->Force
        || $self->FromScratch;

    return unless $do_it;

    $self->_log( "installing" )
        if $tracing;

    $self->cd_to( "BuildDir" );
    $self->_run_build_cmd(
        $self->InstallAsRoot
            ? qw{su -m root -c "make install"}
            : qw{make install}
    );

    $self->_execute_actions;
    $self->_touch_sentinal_file;
}


sub query_installed_version {
    my $self = shift;

    my $version_cmd = $self->InstalledVersionQuery;

    my $output = eval {
        ## A failure to run begets a "" version string
        $self->_run_build_cmd_and_capture_stdout( $version_cmd );
    } || "";
    chomp $output;
    return $output;
}


sub upgrade {
    my $self = shift;

    $self->_log( "checking upgrade" )
        if $tracing;

    ## If it's phony, always "install", which degenerates to building
    ## and installing the prerequisites.  And if forced or fromscratch,
    ## of course.
    if ( $self->IsVirtual || $self->FromScratch || $self->Force ) {
        $self->install;
        $self->_execute_actions;
        return;
    }

    ## NOTE THAT WE USE THE INSTALL SENTINAL HERE!!
    my $sentinal_mtime = $self->_get_sentinal_file_mtime( "install" );

    my $do_it;

    ## See if any prerequisites need an upgrade
    my @r = map $self->{_Container}->get_package( $_ ), $self->Requires;
    for ( @r ) {
        $_->upgrade;
        $do_it ||= $_->_get_sentinal_file_mtime( "upgrade" ) > $sentinal_mtime;
    }

    ## Or if any externalcomponents got freshened
    @r = map $self->{_Container}->get_package( $_ ), $self->ExternalComponents;
    for ( @r ) {
        ## TODO: restructure the macros so components may be placed in
        ## the package as needed.
        $_->unpack;
        $do_it ||= $_->_get_sentinal_file_mtime( "unpack" ) > $sentinal_mtime;
    }

    if ( $do_it ) {
        $self->_loc( "# Prerequisites updated, rebuilding" );
    }
    else {
        my $installedversion = $self->query_installed_version;
        my $minversion = $self->Version;

        if ( ! defined $installedversion || ! length $installedversion ) {
            $self->_log( "# no installed version detected" );
            $do_it = 1;
        }
        elsif ( $self->_cmp_ver( $installedversion, $minversion ) < 0 ) {
            $self->_log( "# $installedversion < $minversion" );
            $do_it = 1;
        }
        else {
            $self->_log( "# $installedversion >= $minversion, not upgrading" );
        }
    }

    return unless $do_it;

    ## Always reinstall if stale, don't download unless necessary
    my $fs_tmp = $self->{FromScratch};
    $self->{FromScratch} = 1;
    my $ok = eval {
        $self->install;
        1;
    };
    if ( defined $fs_tmp ) {
        $self->{FromScratch} = $fs_tmp;
    }
    else {
        delete $self->{FromScratch};
    }
    die $@ unless $ok;
    $self->_execute_actions;

    ## NOTE THAT WE USE OUR OWN SENTINAL FILE HERE!  It's just for
    ## recordkeeping purposes.
    $self->_touch_sentinal_file;
}


package Package::PerlModule;

BEGIN { @Package::PerlModule::ISA = qw( Package ); }

sub _cmp_ver {
    my $self = shift;

    my ( $vera, $verb ) = @_;

    $vera =~ s/_//g;
    $verb =~ s/_//g;

    return ($vera || -1) <=> ($verb || -1 );
}


package Package::GNOME;

BEGIN { @Package::GNOME::ISA = qw( Package ); }


package Installer;

@Installer::ISA = qw( Installer::Thingy );

use Carp;
use File::Copy ();
use File::Path ();
use File::Basename ();

sub new {
    my $self = bless {}, ref $_[0] ? ref shift : shift;

    %$self = %{shift()};  ## TODO: a deep copy.

    $self->{_OSDriver} = OSDriver->new( _Container => $self )
        unless $self->{_OSDriver};

    if ( my $pkgs = delete $self->{Packages} ) {
        $self->add_package( $_ ) for @$pkgs;
    }

    $self->validate;

    return $self;
}


sub add_package {
    my $self = shift;
    my $pkg = UNIVERSAL::isa( $_[0], "Package" )
        ? shift
        : Package->new_subclass( 
            %{shift()},
            _Container => $self,
        );

    my $name = $pkg->Name;
    die "Duplicate package name: $name\n"
        if eval { $self->get_package( $name ) };

    push @{$self->{Packages}}, $pkg;
}


sub get_package {
    my $self = shift;
    my ( $name ) = @_;

    for ( @{$self->{Packages}} ) {
        return $_ if $_->{Name} eq $name;
    }

    die "Unkown package name '$name'\n";
}


sub dump_packages {
    my $self = shift;

    local $self->{_DumpSeen} = {};
    $self->_dump( Packages => $self->{Packages} );
}


sub validate {
    my $self = shift;

    my %options = @_;
    $options{Fatal} = 1 unless defined $options{Fatal};

    my @errors;
    for my $pkg ( @{$self->{Packages}} ) {
        for ( $pkg->Requires ) {
            next if eval { $self->get_package( $_ ); 1 };
            push @errors, $pkg->_fail_msg( " requires unknown package '$_'" );
        }

        for ( $pkg->ExternalComponents ) {
            next if eval { $self->get_package( $_ ); 1 };
            push @errors, $pkg->_fail_msg(
                " requires unknown external component package '$_'"
            );
        }
        my $ok = eval { $pkg->validate; 1 };
        push @errors, $@ unless $ok;
    }

    die @errors if @errors && $options{Fatal};

    return @errors;
}


###############################################################################
###############################################################################
###############################################################################
##
## Main program code
## This must come last so all the file-scope code above runs
##
my $installer = Installer->new( \%db );  ## "package db"
$tracing = 1;
#print $installer->get_package( "AxKit" )->description_as_string();# { ExpandMacros => 1} );
$installer->get_package( "AxKitDemo" )->install;
