File Coverage

lib/Spoon/Installer.pm

Criterion	Covered	Total	%
statement	80	156	51.2
branch	21	70	30.0
condition	4	14	28.5
subroutine	14	22	63.6
pod	0	16	0.0
total	119	278	42.8

package Spoon::Installer;
use Spiffy -Base;
use IO::All;
use Spoon::Base -mixin => qw(hub);

const extract_to => '.';
field quiet => 0;

sub compress_from {
    $self->extract_to;
}

sub extract_files {
    my @files = $self->get_packed_files;
    while (@files) {
        my ($file_name, $file_contents) = splice(@files, 0, 2);
        my $locked = $file_name =~ s/^!//;
        my $file_path = join '/', $self->extract_to, $file_name;
        my $file = io->file($file_path)->assert;
        if ($locked and -f $file_path) {
            warn "  Skipping $file (already exists)\n" unless $self->quiet;
            next;
        }
        my $content = $self->set_file_content($file_path, $file_contents);
        if ($file->exists and $file->all eq $content) {
            warn "  Skipping $file (unchanged)\n" unless $self->quiet;
            next;
        }
        warn "  - $file\n" unless $self->quiet;
        $file->binary if $self->file_is_binary($file_path);
        $file->assert->print($content);
    }
}

sub set_file_content {
    my $path = shift;
    my $content = shift;
    $content = $self->base64_decode($content)
      if $self->file_is_binary($path);
    $content = $self->fix_hashbang($content)
      if $self->file_is_executable($path);
    $content = $self->wrap_html($content, $path)
      if $self->file_is_html($path);
    return $content;
}

sub file_is_binary {
    my $path = shift;
    $path =~ /\.(gif|jpg|png)$/;
}

sub file_is_executable {
    my $path = shift;
    $path =~ /\.(pl|cgi)$/;
}

sub file_is_html {
    my $path = shift;
    $path =~ /\.html$/;
}

sub fix_hashbang {
    require Config;
    my $content = shift;
    $content =~ s/^#!.*\n/$Config::Config{startperl} -w\n/;
    return $content;
}

sub wrap_html {
    my ($content, $path) = @_;
    $path =~ s/^.*\/(.*)$/$1/;
    $path =~ s/\.html$//;
    $content = $self->strip_html($content);
    $content = "\n$content"
      unless $content =~ /^\s/;
    $content = "$content\n"
      unless $content =~ /\s\n\z/;
    return $content;
}

sub get_packed_files {
    my %seen;
    my @return;
    for my $class (@{Spiffy::all_my_bases(ref $self)}) {
        next if $class =~ /-/;
        last if $class =~ /^Spoon/;
        my $data = $self->data($class)
          or next;
        my @files = split /^__(.+)__\n/m, $data;
        shift @files;
        while (@files) {
            my ($name, $content) = splice(@files, 0, 2);
            $name = $self->resolve_install_path($name)
              if $self->can('resolve_install_path');
            my $name2 = $name;
            $name2 =~ s/^\!//;
            next if $seen{$name2}++;
            $content ||= '';
            push @return, $name, $content
              if length $content;
        }
    }
    return @return;
}

sub get_local_packed_files {
    my @return;
    my $class = ref $self;
    my $data = $self->data($class)
      or return;
    my @files = split /^__(.+)__\n/m, $data;
    shift @files;
    while (@files) {
        my ($name, $content) = splice(@files, 0, 2);
        $name = $self->resolve_install_path($name)
          if $self->can('resolve_install_path');
        push @return, $name, $content;
    }
    return @return;
}

sub data {
    my $package = shift || ref($self);
    local $SIG{__WARN__} = sub {};
    local $/;
    eval "package $package; ";
}

sub compress_files {
    require File::Spec;
    my $source_dir = shift;
    my $new_pack = '';
    my @files = $self->get_local_packed_files;
    my $first_file = $files[0]
      or return;
    my $directory = $self->compress_from;
    while (@files) {
        my ($file_name, $file_contents) = splice(@files, 0, 2);
        my $locked = $file_name =~ s/^!// ? '!' : '';
        my $source_path =
          File::Spec->canonpath("$source_dir/$directory/$file_name");
        die "$file_name does not exist as $source_path"
          unless -f $source_path;
        my $content = $locked
        ? $file_contents
        : $self->get_file_content($source_path);
        $content =~ s/\r\n/\n/g;
        $content =~ s/\r/\n/g;
        $new_pack .= "__$locked${file_name}__\n$content";
    }
    my $module = ref($self) . '.pm';
    $module =~ s/::/\//g;
    my $module_path = $INC{$module} or die;
    my $module_text = io($module_path)->all;
    my ($module_code) = split /^__\Q$first_file\E__\n/m, $module_text;
    ($module_code . $new_pack) > io($module_path);
}

sub get_file_content {
    my $path = shift;
    my $content = io($path)->all;
    $content = $self->base64_encode($content)
      if $self->file_is_binary($path);
    $content = $self->unfix_hashbang($content)
      if $self->file_is_executable($path);
    $content = $self->strip_html($content)
      if $self->file_is_html($path);
    $content .= "\n"
      unless $content =~ /\n\z/;
    return $content;
}

sub unfix_hashbang {
    my $content = shift;
    $content =~ s/^#!.*\n/#!\/usr\/bin\/perl\n/;
    return $content;
}

sub strip_html {
    my $content = shift;
    $content =~ s/^\n//;
    $content =~ s/(?<=\n)\n\z//;
    return $content;
}

sub compress_lib {
    die "Must be run from the module source code directory\n"
      unless -d 'lib' and -f 'Makefile.PL';
    unshift @INC,'lib';
    my $source_dir = shift
      or die "No source directory specified\n";
    die "Invalid source directory '$source_dir'\n"
      unless -d $source_dir;
    map {
        my $class_name = $_;
        my $class_id = $class_name->class_id;
        $self->hub->config->add_config(
            +{ "${class_id}_class" => $class_name }
        );
        warn "Compressing $class_name\n" unless $self->quiet;
        $self->hub->$class_id->compress_files($source_dir);
    }
    grep {
        my $name = $_;
        eval "require $name";
        die $@ if $@;
        UNIVERSAL::can($name, 'compress_files')
          and $name !~ /::(Installer)$/;
    } map {
        my $name = $_->name;
        ($name =~ s/^lib\/(.*)\.pm$/$1/) ? do {
            $name =~ s/\//::/g;
            $name;
        } : ();
    } io('lib')->All_Files;
}

__END__