diff options
Diffstat (limited to 'util/dm.pl')
| -rwxr-xr-x | util/dm.pl | 269 |
1 files changed, 269 insertions, 0 deletions
diff --git a/util/dm.pl b/util/dm.pl new file mode 100755 index 000000000..5f743668d --- /dev/null +++ b/util/dm.pl @@ -0,0 +1,269 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use File::Find; +use File::Spec; +use Cwd; +use Getopt::Long; +use Pod::Usage; +use Archive::Tar; +use IPC::Open2; +use POSIX; + +package NIC::Archive::Tar::File; +use parent "Archive::Tar::File"; +sub new { + my $class = shift; + my $self = Archive::Tar::File->new(@_); + bless($self, $class); + return $self; +} + +sub full_path { + my $self = shift; + my $full_path = $self->SUPER::full_path(); $full_path = '' unless defined $full_path; + $full_path =~ s#^#./# if $full_path ne "" && $full_path ne "." && $full_path !~ m#^\./#; + return $full_path; +} +1; +package main; + +our $VERSION = '2.0'; + +our $_PROGNAME = "dm.pl"; + +my $ADMINARCHIVENAME = "control.tar.gz"; +my $DATAARCHIVENAME = "data.tar"; +my $ARCHIVEVERSION = "2.0"; + +our $compression = "gzip"; +our $compresslevel = -1; +Getopt::Long::Configure("bundling", "auto_version"); +GetOptions('compression|Z=s' => \$compression, + 'compress-level|z=i' => \$compresslevel, + 'build|b' => sub { }, + 'help|?' => sub { pod2usage(1); }, + 'man' => sub { pod2usage(-exitstatus => 0, -verbose => 2); }) + or pod2usage(2); + +pod2usage(1) if(@ARGV < 2); + +if($compresslevel < 0 || $compresslevel > 9) { + $compresslevel = 6; + $compresslevel = 9 if $compression eq "bzip2"; +} + +if(($compression eq "bzip2" || $compression eq "gzip") && $compresslevel eq 0) { + $compresslevel = 1; +} + +my $pwd = Cwd::cwd(); +my $indir = File::Spec->rel2abs($ARGV[0]); +my $outfile = $ARGV[1]; + +die "ERROR: '$indir' is not a directory or does not exist.\n" unless -d $indir; + +my $controldir = File::Spec->catpath("", $indir, "DEBIAN"); + +die "ERROR: control directory '$controldir' is not a directory or does not exist.\n" unless -d $controldir; +my $mode = (lstat($controldir))[2]; +die sprintf("ERROR: control directory has bad permissions %03lo (must be >=0755 and <=0775)\n", $mode & 07777) if(($mode & 07757) != 0755); + +my $controlfile = File::Spec->catfile($controldir, "control"); +die "ERROR: control file '$controlfile' is not a plain file\n" unless -f $controlfile; +my %control_data = read_control_file($controlfile); + +die "ERROR: control file '$controlfile' is missing a Package field" unless defined $control_data{"package"}; +die "ERROR: control file '$controlfile' is missing a Version field" unless defined $control_data{"version"}; +die "ERROR: control file '$controlfile' is missing an Architecture field" unless defined $control_data{"architecture"}; + +die "ERROR: package name has characters that aren't lowercase alphanums or '-+.'.\n" if($control_data{"package"} =~ m/[^a-z0-9+-._]/); +die "ERROR: package version ".$control_data{"version"}." doesn't contain any digits.\n" if($control_data{"version"} !~ m/[0-9]/); + +foreach my $m ("preinst", "postinst", "prerm", "postrm", "extrainst_") { + $_ = File::Spec->catfile($controldir, $m); + next unless -e $_; + die "ERROR: maintainer script '$m' is not a plain file or symlink\n" unless(-f $_ || -l $_); + $mode = (lstat)[2]; + die sprintf("ERROR: maintainer script '$m' has bad permissions %03lo (must be >=0555 and <=0775)\n", $mode & 07777) if(($mode & 07557) != 0555) +} + +if (-d "$outfile") { + $outfile = sprintf('%s/%s_%s_%s.deb', $outfile, $control_data{"package"}, $control_data{"version"}, $control_data{"architecture"}); +} + +print "$_PROGNAME: building package `".$control_data{"package"}.":".$control_data{"architecture"}."' in `$outfile'\n"; + +open(my $ar, '>', $outfile) or die $!; + +print $ar "!<arch>\n"; +print_ar_record($ar, "debian-binary", time, 0, 0, 0100644, 4); +print_ar_file($ar, "$ARCHIVEVERSION\n", 4); + +{ + my $tar = Archive::Tar->new(); + $tar->add_files(tar_filelist($controldir)); + my $comp; + my $zFd = IO::Compress::Gzip->new(\$comp, -Level => 9); + $tar->write($zFd); + $zFd->close(); + print_ar_record($ar, $ADMINARCHIVENAME, time, 0, 0, 0100644, length($comp)); + print_ar_file($ar, $comp, length($comp)); +} { + my $tar = Archive::Tar->new(); + $tar->add_files(tar_filelist($indir)); + my ($fh_out, $fh_in); + my $pid = open2($fh_out, $fh_in, compression_cmd()) or die "ERROR: open2 failed to create pipes for '$::compression'\n"; + fcntl($fh_out, F_SETFL, O_NONBLOCK); + fcntl($fh_in, F_SETFL, O_NONBLOCK); + my $tmp_data = $tar->write(); + my $tmp_size = length($tmp_data); + + my ($off_in, $off_out) = (0, 0); + my ($archivedata, $archivesize); + while($off_in < $tmp_size) { + my ($rin, $win) = ('', ''); + my ($rout, $wout); + vec($win, fileno($fh_in), 1) = 1; + vec($rin, fileno($fh_out), 1) = 1; + # Wait for space to be available to write or data to be available to read + select($rout=$rin, $wout=$win, undef, undef); + if (vec($wout, fileno($fh_in), 1)) { + # Write 8KB of data + my $wrote = syswrite $fh_in, $tmp_data, 8192, $off_in; + $off_in += $wrote if (defined $wrote); + } + if (vec($rin, fileno($fh_out), 1)) { + # Get the compressed result if possible + my $o = sysread $fh_out, $archivedata, 8192, $off_out; + $off_out += $o if (defined($o)); + } + } + $fh_in->close(); + + while (1) { + # Get the remaining data + my $o = sysread $fh_out, $archivedata, 8192, $off_out; + if (defined($o) && $o > 0) { + $off_out += $o; + } elsif ($! != EAGAIN) { + last; + } + } + $archivesize = $off_out; + $fh_out->close(); + waitpid($pid, 0); + print_ar_record($ar, compressed_filename($DATAARCHIVENAME), time, 0, 0, 0100644, $archivesize); + print_ar_file($ar, $archivedata, $archivesize); +} + +close $ar; + +sub print_ar_record { + my ($fh, $filename, $timestamp, $uid, $gid, $mode, $size) = @_; + printf $fh "%-16s%-12lu%-6lu%-6lu%-8lo%-10ld`\n", $filename, $timestamp, $uid, $gid, $mode, $size; + $fh->flush(); +} + +sub print_ar_file { + my ($fh, $data, $size) = @_; + syswrite $fh, $data; + print $fh "\n" if($size % 2 == 1); + $fh->flush(); +} + +sub tar_filelist { + my $dir = getcwd; + chdir(shift); + my @filelist; + my @symlinks; + + find({wanted => sub { + return if m#^./DEBIAN#; + my $tf = NIC::Archive::Tar::File->new(file=>$_); + my $mode = (lstat($_))[2] & 07777; + $tf->mode($mode); + $tf->chown("root", "wheel"); + push @symlinks, $tf if -l; + push @filelist, $tf if ! -l; + }, no_chdir => 1}, "."); + chdir($dir); + return (@filelist, @symlinks); +} + +sub read_control_file { + my $filename = shift; + open(my $fh, '<', $filename) or die "ERROR: can't open control file '$filename'\n"; + my %data; + while(<$fh>) { + die "ERROR: control file contains Windows/Macintosh line endings - please use a text editor or dos2unix to change to Unix line endings\n" if(m/\r/); + if(m/^(.*?): (.*)/) { + $data{lc($1)} = $2; + } + } + close $fh; + return %data; +} + +sub compression_cmd { + return "gzip -c".$compresslevel if $::compression eq "gzip"; + return "bzip2 -c".$compresslevel if $::compression eq "bzip2"; + return "lzma -c".$compresslevel if $::compression eq "lzma"; + return "xz -c".$compresslevel if $::compression eq "xz"; + if($::compression ne "cat") { + print "WARNING: compressor '$::compression' is unknown, falling back to cat.\n"; + } + return "cat"; +} + +sub compressed_filename { + my $fn = shift; + my $suffix = ""; + $suffix = ".gz" if $::compression eq "gzip"; + $suffix = ".bz2" if $::compression eq "bzip2"; + $suffix = ".lzma" if $::compression eq "lzma"; + $suffix = ".xz" if $::compression eq "xz"; + return $fn.$suffix; +} + +__END__ + +=head1 NAME + +dm.pl + +=head1 SYNOPSIS + +dm.pl [options] <directory> <package> + +=head1 OPTIONS + +=over 8 + +=item B<-b> + +This option exists solely for compatibility with dpkg-deb. + +=item B<-ZE<lt>compressionE<gt>> + +Specify the package compression type. Valid values are gzip (default), bzip2, lzma, xz and cat (no compression.) + +=item B<-zE<lt>compress-levelE<gt>> + +Specify the package compression level. Valid values are between 0 and 9. Default is 9 for bzip2, 6 for others. 0 is identical to 1 when using bzip2 and gzip. Refer to B<gzip(1)>, B<bzip2(1)>, B<xz(1)> for explanations of what effect each compression level has. + +=item B<--help>, B<-?> + +Print a brief help message and exit. + +=item B<--man> + +Print a manual page and exit. + +=back + +=head1 DESCRIPTION + +B<This program> creates Debian software packages (.deb files) and is a drop-in replacement for dpkg-deb. + +=cut |