File Coverage

blib/lib/Archive/Ipkg.pm

Criterion	Covered	Total	%
statement	185	208	88.9
branch	82	120	68.3
condition	33	48	68.7
subroutine	31	34	91.1
pod	28	28	100.0
total	359	438	81.9

package Archive::Ipkg;

use strict;
use warnings;
use Carp;

use lib qw(.);

use Archive::Tar;
use Compress::Zlib;

our $VERSION = '0.04';

# constructor
sub new {
    my $class = shift;
    my %opts = @_;

    my $self = {};

    $self->{sloppy} = 0;
    $self->{sloppy} = $opts{sloppy}
        if exists $opts{sloppy};

    bless $self, $class;

    # initialize properties without defaults
    $self->config_files(@{$opts{config_files}})
        if exists $opts{config_files};
    $self->depends($opts{depends})
        if exists $opts{depends};
    $self->description($opts{description})
        if exists $opts{description};
    $self->filename($opts{filename})
        if exists $opts{filename};
    $self->maintainer($opts{maintainer})
        if exists $opts{maintainer};
    $self->name($opts{name})
        if exists $opts{name};
    $self->preinst_script($opts{preinst_script})
        if exists $opts{preinst_script};
    $self->postinst_script($opts{postinst_script})
        if exists $opts{postinst_script};
    $self->prerm_script($opts{prerm_script})
        if exists $opts{prerm_script};
    $self->postrm_script($opts{postrm_script})
        if exists $opts{postrm_script};

    # initialize properties with defaults
    $self->architecture(exists $opts{architecture} ?
        $opts{architecture} : $self->default_architecture);
    $self->priority(exists $opts{priority} ?
        $opts{priority} : $self->default_priority);
    $self->section(exists $opts{section} ?
        $opts{section} : $self->default_section);
    $self->version(exists $opts{version} ?
        $opts{version} : $self->default_version);

    # initialize internal archives
    $self->{TAR_CONTROL} = undef; # create when saving
    $self->{TAR_DATA} = Archive::Tar->new();
    $self->{TAR_IPKG} = undef; # create when saving

    return $self;
}

# control property checking
sub sloppy_checks {
    my $self = shift;

    $self->{sloppy} = 1;
}

sub strict_checks {
    my $self = shift;

    $self->{sloppy} = 0;
}


# default values for properties
sub default_architecture {
    return "arm";
}

sub default_priority {
    return "optional";
}

sub default_section {
    return "misc";
}

sub default_version {
    return "";
}

# accessor functions for properties
sub config_files {
    my $self = shift;
    my $config_files = shift;

    $self->{config_files} = $config_files
        if (defined $config_files && ref $config_files);
    return $self->{config_files};
}

sub depends {
    my $self = shift;
    my $depends = shift;

    return $self->{depends} unless defined $depends;

    if ($self->{sloppy} || $depends =~ /^[a-z0-9.+-]+(,[a-z0-9.+-]+)*$/) {
        $self->{depends} = $depends;
    } else {
        $self->{depends} = undef;
    }

    return $self->{depends};
}

sub description {
    my $self = shift;
    my $description = shift;

    return $self->{description} unless defined $description;

    if ($self->{sloppy} || $description =~ /\S/) {
        $self->{description} = $description;
    } else {
        $self->{description} = undef;
    }

    return $self->{description};
}

sub filename {
    my $self = shift;
    my $filename = shift;

    if (defined $filename) {
        $self->{filename} = $filename;
    } elsif (!defined $self->{filename}) {
        if (defined $self->{name}) {
	    $self->{filename} = $self->{name};

	    $self->{filename} .= "_" . $self->{version}
                if (defined $self->{version} &&
		    $self->{version} =~ /\S/);
	    $self->{filename} .= "_" . $self->{architecture}
                if (defined $self->{architecture} &&
		    $self->{architecture} =~ /\S/);
	    $self->{filename} .= ".ipk";
	}
    }

    return $self->{filename};
}

sub maintainer {
    my $self = shift;
    my $maintainer = shift;

    return $self->{maintainer} unless defined $maintainer;

    if ($self->{sloppy} || $maintainer =~ /\@/) {
        $self->{maintainer} = $maintainer;
    } else {
        $self->{maintainer} = undef;
    }

    return $self->{maintainer};
}

sub name {
    my $self = shift;
    my $name = shift;

    return $self->{name} unless defined $name;

    if ($self->{sloppy} || $name =~ /^[a-z0-9.+-]+$/) {
        $self->{name} = $name;
    } else {
        $self->{name} = undef;
    }

    return $self->{name};
}

sub preinst_script {
    my $self = shift;
    my $preinst_script = shift;

    $self->{preinst_script} = $preinst_script if defined $preinst_script;
    return $self->{preinst_script};
}

sub postinst_script {
    my $self = shift;
    my $postinst_script = shift;

    $self->{postinst_script} = $postinst_script if defined $postinst_script;
    return $self->{postinst_script};
}

sub prerm_script {
    my $self = shift;
    my $prerm_script = shift;

    $self->{prerm_script} = $prerm_script if defined $prerm_script;
    return $self->{prerm_script};
}

sub postrm_script {
    my $self = shift;
    my $postrm_script = shift;

    $self->{postrm_script} = $postrm_script if defined $postrm_script;
    return $self->{postrm_script};
}

sub architecture {
    my $self = shift;
    my $architecture = shift;

    return $self->{architecture} unless defined $architecture;

    if ($self->{sloppy} || $architecture =~ /^arm|all$/) {
        $self->{architecture} = $architecture;
    } else {
        $self->{architecture} = undef;
    }

    return $self->{architecture};
}

sub priority {
    my $self = shift;
    my $priority = shift;

    return $self->{priority} unless defined $priority;

    if ($self->{sloppy} || $priority =~ /^required|standard|important|optional|extra$/) {
        $self->{priority} = $priority;
    } else {
        $self->{priority} = undef;
    }

    return $self->{priority};
}

sub section {
    my $self = shift;
    my $section = shift;

    my @zaurus_sections = qw(Games Multimedia Communications Settings
                             Utilities Applications Console Misc);
    my @familiar_sections = qw(admin base comm editors extras graphics libs
                               misc net text web x11);
    my $regex = '^' . join('|', @zaurus_sections, @familiar_sections) . '$';

    return $self->{section} unless defined $section;

    if ($self->{sloppy} || $section =~ $regex) {
        $self->{section} = $section;
    } else {
        $self->{section} = undef;
    }

    return $self->{section};
}

sub version {
    my $self = shift;
    my $version = shift;

    return $self->{version} unless defined $version;

    if ($self->{sloppy} ||
	($version =~ /^[a-zA-Z0-9.+]*$/ && $version =~ /\d/)) {
        $self->{version} = $version;
    } elsif ($version =~ /^\s*$/) {
	$self->{version} = "";
    } else {
        $self->{version} = undef;
    }

    return $self->{version};
}

# verification

sub verify {
    my $self = shift;
    my $verify = undef;

# required: package, version, architecture, maintainer, section, description
    $verify .= "No package name\n" unless (defined $self->{name});
    # version should be at least empty
    $verify .= "No version\n" unless (defined $self->{architecture});
    $verify .= "No architecture\n" unless (defined $self->{architecture});
    $verify .= "No maintainer\n" unless (defined $self->{maintainer});
    $verify .= "No section\n" unless (defined $self->{section});

    $verify .= "No description\n" unless (defined $self->{description});

    return $verify;
}

# file handling

sub add_files {
    my $self = shift;

    return $self->{TAR_DATA}->add_files(@_);
}

sub add_file {
    my $self = shift;
    my ($filename, $new_filename) = @_;

    $new_filename = $filename unless defined $new_filename;
    $new_filename =~ s|^/?|./|;

    return undef unless open(ADDFILE, "<$filename");
    binmode ADDFILE;
    local $/; undef $/;
    $self->{TAR_DATA}->add_data($new_filename, , { mode => 0100644 });
    close(ADDFILE);

    return 1;
}

sub add_file_by_data {
    my $self = shift;
    my ($filename, $data, $opts) = @_;

    $filename =~ s|^/?|./|;

    $opts = { mode => 0100644 }
      unless (defined $opts && ref $opts && exists $opts->{mode});

    return $self->{TAR_DATA}->add_data($filename, $data, $opts);
}

# whole archive handling

# returns "control" file contents
sub control {
    my $self = shift;

    my $control = '';

    $control .= "Package: " . $self->{name} . "\n";
    $control .= "Priority: " . $self->{priority} . "\n"
        if (defined $self->{priority});
    $control .= "Section: " . $self->{section} . "\n";
    $control .= "Version: " . $self->{version} . "\n";
    $control .= "Architecture: " . $self->{architecture} . "\n";
    $control .= "Maintainer: " . $self->{maintainer} . "\n";
    $control .= "Depends: " . $self->{depends} . "\n"
        if (defined $self->{depends});

    my $desc = $self->{description};
    # start lines with space
    $desc =~ s/\n/ \n/g;
    # start empty lines with space and .
    $desc =~ s/\n \n/\n .\n/g;
    $control .= "Description: $desc\n";

    return $control;
}

sub data {
    my $self = shift;

    return undef if $self->verify;
    # make control package
    $self->{TAR_CONTROL} = Archive::Tar->new();

    $self->{TAR_CONTROL}->add_data("./control", $self->control, { mode => 0100644 });
    foreach (qw(preinst postinst prerm postrm)) {
        $self->{TAR_CONTROL}->add_data("./$_", $self->{$_},
            {mode => 0100755}) if (defined $self->{$_});
    }

    $self->{TAR_CONTROL}->add_data("./conffiles",
        join"\n", $self->{config_files}, { mode => 0100644 })
        if (defined $self->{config_files} && ref $self->{config_files});

    # make package
    $self->{TAR_IPKG} = Archive::Tar->new();
    $self->{TAR_IPKG}->add_data("./debian-binary", "2.0\n", { mode => 0100644 });

    my ($tar_data);

    $tar_data = Compress::Zlib::memGzip($self->{TAR_DATA}->write());
    return undef unless defined $tar_data;
    $self->{TAR_IPKG}->add_data("./data.tar.gz",
        $tar_data, { mode => 0100644 });

    $tar_data = Compress::Zlib::memGzip($self->{TAR_CONTROL}->write());

    return undef unless defined $tar_data;
    $self->{TAR_IPKG}->add_data("./control.tar.gz",
        $tar_data, { mode => 0100644 });

    $tar_data = Compress::Zlib::memGzip($self->{TAR_IPKG}->write());
    return $tar_data;
}

sub write {
    my $self = shift;

    my $filename = $self->filename;
    my $data = $self->data;

    return undef unless ($filename && defined $data);

    open IPKG, ">$filename" or carp "Can't write iPKG '$filename': $!";
    binmode IPKG;
    print IPKG $data;
    close IPKG;
}

1;
__END__