From Code to Community: Sponsoring The Perl and Raku Conference 2025 Learn more

SUNNAVY / Shipwright-1.15 / lib / Shipwright / Source / Compressed.pm 

            

              
1
2
3
4
5
6
7
8
9
10
—
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
—
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
—
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130

              
package Shipwright::Source::Compressed;
use warnings;
use strict;
use Carp;
use File::Spec::Functions qw/catfile catdir/;
use base qw/Shipwright::Source::Base/;
use Archive::Extract;
use File::Temp qw/tempdir/;
=head2 run
=cut
sub run {
    my $self = shift;
    $self->name( $self->just_name( $self->path ) )       unless $self->name;
    $self->version( $self->just_version( $self->path ) ) unless $self->version;
    $self->log->info( 'run source ' . $self->name . ': ' . $self->source );
    $self->_update_version( $self->name, $self->version );
    $self->_update_url( $self->name, 'file:' . $self->source )
      unless $self->{_no_update_url};
    my $newer = $self->_cmd;    # if we really get something new
    my $ret = $self->SUPER::run(@_);
    # follow only if --follow and we really added new stuff.
    $self->_follow( catdir( $self->directory, $self->name ) )
      if $self->follow && $newer;
    return catdir( $self->directory, $self->name );
}
=head2 path
the decompressed source path
=cut
sub path {
    my $self   = shift;
    # we memoize path info so we don't need to extract on each call.
    return $self->{_path} if $self->{_path};
    my $source = $self->source;
    my $ae = Archive::Extract->new( archive => $source );
    # this's to check if $source is valid, aka. it only contains one directory.
    my $tmp_dir = tempdir( 'shipwright_tmp_XXXXXX', CLEANUP => 1, TMPDIR => 1 );
    $ae->extract( to => $tmp_dir );
    my $files = $ae->files;
    my $base_dir = $files->[0];
    if ( @$files != grep { /^\Q$base_dir\E/ } @$files ) {
        croak 'only support compressed file which contains only one directory';
    }
    $base_dir =~ s![/\\]$!!; # trim the last / or \\ if possible
    $self->{_path} = $base_dir;
    return $base_dir;
}
sub _cmd {
    my $self = shift;
    my $arg;
    my ( $from, $to );
    $from = catdir( $self->directory, $self->path );
    $to   = catdir( $self->directory, $self->name );
    # if it already exists, assuming we have processed it already, don't do it
    # again
    return if -e $to;
    my $ae = Archive::Extract->new( archive => $self->source );
    my @cmds;
    push @cmds, sub { $ae->extract( to => $self->directory ) };
    if ( $from ne $to ) {
        push @cmds, [ 'mv', $from, $to ];
    }
    return @cmds;
}
1;
__END__
=head1 NAME
Shipwright::Source::Compressed - compressed source
=head1 DESCRIPTION
=head1 DEPENDENCIES
None.
=head1 INCOMPATIBILITIES
None reported.
=head1 BUGS AND LIMITATIONS
No bugs have been reported.
=head1 AUTHOR
sunnavy  C<< <sunnavy@bestpractical.com> >>
=head1 LICENCE AND COPYRIGHT
Copyright 2007 Best Practical Solutions.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.