Skip to content

Commit 55ccfd5

Browse files
KritantaDevKritantaDev
KritantaDev
authored and
KritantaDev
committed
Add dm.pl
1 parent cd945fb commit 55ccfd5

3 files changed

Lines changed: 283 additions & 0 deletions

File tree

‎dm.pl/.gitignore‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,3 @@
1+
.DS_Store
2+
.theos
3+
packages

‎dm.pl/LICENSE.md‎

Lines changed: 21 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,21 @@
1+
MIT License
2+
3+
Copyright (c) 2017 Theos
4+
5+
Permission is hereby granted, free of charge, to any person obtaining a copy
6+
of this software and associated documentation files (the "Software"), to deal
7+
in the Software without restriction, including without limitation the rights
8+
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
9+
copies of the Software, and to permit persons to whom the Software is
10+
furnished to do so, subject to the following conditions:
11+
12+
The above copyright notice and this permission notice shall be included in all
13+
copies or substantial portions of the Software.
14+
15+
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16+
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17+
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18+
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19+
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
20+
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
21+
SOFTWARE.

‎dm.pl/dm.pl‎

Lines changed: 259 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,259 @@
1+
#!/usr/bin/env perl
2+
use strict;
3+
use warnings;
4+
use File::Find;
5+
use File::Spec;
6+
use Cwd;
7+
use Getopt::Long;
8+
use Pod::Usage;
9+
use Archive::Tar;
10+
use IPC::Open2;
11+
use POSIX;
12+
13+
package NIC::Archive::Tar::File;
14+
use parent "Archive::Tar::File";
15+
sub new {
16+
my $class = shift;
17+
my $self = Archive::Tar::File->new(@_);
18+
bless($self, $class);
19+
return $self;
20+
}
21+
22+
sub full_path {
23+
my $self = shift;
24+
my $full_path = $self->SUPER::full_path(); $full_path = '' unless defined $full_path;
25+
$full_path =~ s#^#./# if $full_path ne "" && $full_path ne "." && $full_path !~ m#^\./#;
26+
return $full_path;
27+
}
28+
1;
29+
package main;
30+
31+
our $VERSION = '2.0';
32+
33+
our $_PROGNAME = "dm.pl";
34+
35+
my $ADMINARCHIVENAME = "control.tar.gz";
36+
my $DATAARCHIVENAME = "data.tar";
37+
my $ARCHIVEVERSION = "2.0";
38+
39+
our $compression = "gzip";
40+
our $compresslevel = -1;
41+
Getopt::Long::Configure("bundling", "auto_version");
42+
GetOptions('compression|Z=s' => \$compression,
43+
'compress-level|z=i' => \$compresslevel,
44+
'build|b' => sub { },
45+
'help|?' => sub { pod2usage(1); },
46+
'man' => sub { pod2usage(-exitstatus => 0, -verbose => 2); })
47+
or pod2usage(2);
48+
49+
pod2usage(1) if(@ARGV < 2);
50+
51+
if($compresslevel < 0 || $compresslevel > 9) {
52+
$compresslevel = 6;
53+
$compresslevel = 9 if $compression eq "bzip2";
54+
}
55+
56+
if($compresslevel eq 0) {
57+
$compresslevel = 1;
58+
}
59+
60+
my $pwd = Cwd::cwd();
61+
my $indir = File::Spec->rel2abs($ARGV[0]);
62+
my $outfile = $ARGV[1];
63+
64+
die "ERROR: '$indir' is not a directory or does not exist.\n" unless -d $indir;
65+
66+
my $controldir = File::Spec->catpath("", $indir, "DEBIAN");
67+
68+
die "ERROR: control directory '$controldir' is not a directory or does not exist.\n" unless -d $controldir;
69+
my $mode = (lstat($controldir))[2];
70+
die sprintf("ERROR: control directory has bad permissions %03lo (must be >=0755 and <=0775)\n", $mode & 07777) if(($mode & 07757) != 0755);
71+
72+
my $controlfile = File::Spec->catfile($controldir, "control");
73+
die "ERROR: control file '$controlfile' is not a plain file\n" unless -f $controlfile;
74+
my %control_data = read_control_file($controlfile);
75+
76+
die "ERROR: control file '$controlfile' is missing a Package field" unless defined $control_data{"package"};
77+
die "ERROR: control file '$controlfile' is missing a Version field" unless defined $control_data{"version"};
78+
die "ERROR: control file '$controlfile' is missing an Architecture field" unless defined $control_data{"architecture"};
79+
80+
die "ERROR: package name has characters that aren't lowercase alphanums or '-+.'.\n" if($control_data{"package"} =~ m/[^a-z0-9+-.]/);
81+
die "ERROR: package version ".$control_data{"version"}." doesn't contain any digits.\n" if($control_data{"version"} !~ m/[0-9]/);
82+
83+
foreach my $m ("preinst", "postinst", "prerm", "postrm", "extrainst_") {
84+
$_ = File::Spec->catfile($controldir, $m);
85+
next unless -e $_;
86+
die "ERROR: maintainer script '$m' is not a plain file or symlink\n" unless(-f $_ || -l $_);
87+
$mode = (lstat)[2];
88+
die sprintf("ERROR: maintainer script '$m' has bad permissions %03lo (must be >=0555 and <=0775)\n", $mode & 07777) if(($mode & 07557) != 0555)
89+
}
90+
91+
if (-d "$outfile") {
92+
$outfile = sprintf('%s/%s_%s_%s.deb', $outfile, $control_data{"package"}, $control_data{"version"}, $control_data{"architecture"});
93+
}
94+
95+
print "$_PROGNAME: building package `".$control_data{"package"}.":".$control_data{"architecture"}."' in `$outfile'\n";
96+
97+
open(my $ar, '>', $outfile) or die $!;
98+
99+
print $ar "!<arch>\n";
100+
print_ar_record($ar, "debian-binary", time, 0, 0, 0100644, 4);
101+
print_ar_file($ar, "$ARCHIVEVERSION\n", 4);
102+
103+
{
104+
my $tar = Archive::Tar->new();
105+
$tar->add_files(tar_filelist($controldir));
106+
my $comp;
107+
my $zFd = IO::Compress::Gzip->new(\$comp, -Level => 9);
108+
$tar->write($zFd);
109+
$zFd->close();
110+
print_ar_record($ar, $ADMINARCHIVENAME, time, 0, 0, 0100644, length($comp));
111+
print_ar_file($ar, $comp, length($comp));
112+
} {
113+
my $tar = Archive::Tar->new();
114+
$tar->add_files(tar_filelist($indir));
115+
my ($fh_out, $fh_in);
116+
my $pid = open2($fh_out, $fh_in, compression_cmd()) or die "ERROR: open2 failed to create pipes for '$::compression'\n";
117+
fcntl($fh_out, F_SETFL, O_NONBLOCK);
118+
my $tmp_data = $tar->write();
119+
my $tmp_size = length($tmp_data);
120+
121+
my ($off_in, $off_out) = (0, 0);
122+
my ($archivedata, $archivesize);
123+
while($off_in < $tmp_size) {
124+
# Write 8KB of data
125+
$off_in += syswrite $fh_in, $tmp_data, 8192, $off_in;
126+
# Get the compressed result if possible
127+
my $o = sysread $fh_out, $archivedata, 8192, $off_out;
128+
if (defined($o)) {
129+
$off_out += $o;
130+
}
131+
}
132+
$fh_in->close();
133+
134+
while (1) {
135+
# Get the remaining data
136+
my $o = sysread $fh_out, $archivedata, 8192, $off_out;
137+
if (defined($o) && $o > 0) {
138+
$off_out += $o;
139+
} elsif ($! != EAGAIN) {
140+
last;
141+
}
142+
}
143+
$archivesize = $off_out;
144+
$fh_out->close();
145+
waitpid($pid, 0);
146+
print_ar_record($ar, compressed_filename($DATAARCHIVENAME), time, 0, 0, 0100644, $archivesize);
147+
print_ar_file($ar, $archivedata, $archivesize);
148+
}
149+
150+
close $ar;
151+
152+
sub print_ar_record {
153+
my ($fh, $filename, $timestamp, $uid, $gid, $mode, $size) = @_;
154+
printf $fh "%-16s%-12lu%-6lu%-6lu%-8lo%-10ld`\n", $filename, $timestamp, $uid, $gid, $mode, $size;
155+
$fh->flush();
156+
}
157+
158+
sub print_ar_file {
159+
my ($fh, $data, $size) = @_;
160+
syswrite $fh, $data;
161+
print $fh "\n" if($size % 2 == 1);
162+
$fh->flush();
163+
}
164+
165+
sub tar_filelist {
166+
my $dir = getcwd;
167+
chdir(shift);
168+
my @filelist;
169+
my @symlinks;
170+
171+
find({wanted => sub {
172+
return if m#^./DEBIAN#;
173+
my $tf = NIC::Archive::Tar::File->new(file=>$_);
174+
my $mode = (lstat($_))[2] & 07777;
175+
$tf->mode($mode);
176+
$tf->chown("root", "wheel");
177+
push @symlinks, $tf if -l;
178+
push @filelist, $tf if ! -l;
179+
}, no_chdir => 1}, ".");
180+
chdir($dir);
181+
return (@filelist, @symlinks);
182+
}
183+
184+
sub read_control_file {
185+
my $filename = shift;
186+
open(my $fh, '<', $filename) or die "ERROR: can't open control file '$filename'\n";
187+
my %data;
188+
while(<$fh>) {
189+
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/);
190+
if(m/^(.*?): (.*)/) {
191+
$data{lc($1)} = $2;
192+
}
193+
}
194+
close $fh;
195+
return %data;
196+
}
197+
198+
sub compression_cmd {
199+
return "gzip -c".$compresslevel if $::compression eq "gzip";
200+
return "bzip2 -c".$compresslevel if $::compression eq "bzip2";
201+
return "lzma -c".$compresslevel if $::compression eq "lzma";
202+
return "xz -c".$compresslevel if $::compression eq "xz";
203+
if($::compression ne "cat") {
204+
print "WARNING: compressor '$::compression' is unknown, falling back to cat.\n";
205+
}
206+
return "cat";
207+
}
208+
209+
sub compressed_filename {
210+
my $fn = shift;
211+
my $suffix = "";
212+
$suffix = ".gz" if $::compression eq "gzip";
213+
$suffix = ".bz2" if $::compression eq "bzip2";
214+
$suffix = ".lzma" if $::compression eq "lzma";
215+
$suffix = ".xz" if $::compression eq "xz";
216+
return $fn.$suffix;
217+
}
218+
219+
__END__
220+
221+
=head1 NAME
222+
223+
dm.pl
224+
225+
=head1 SYNOPSIS
226+
227+
dm.pl [options] <directory> <package>
228+
229+
=head1 OPTIONS
230+
231+
=over 8
232+
233+
=item B<-b>
234+
235+
This option exists solely for compatibility with dpkg-deb.
236+
237+
=item B<-ZE<lt>compressionE<gt>>
238+
239+
Specify the package compression type. Valid values are gzip (default), bzip2, lzma, xz and cat (no compression.)
240+
241+
=item B<-zE<lt>compress-levelE<gt>>
242+
243+
Specify the package compression level. Valid values are between 1 and 9. Default is 9 for bzip2, 6 for others. 0 is identical to 1. Refer to B<gzip(1)>, B<bzip2(1)>, B<xz(1)> for explanations of what effect each compression level has.
244+
245+
=item B<--help>, B<-?>
246+
247+
Print a brief help message and exit.
248+
249+
=item B<--man>
250+
251+
Print a manual page and exit.
252+
253+
=back
254+
255+
=head1 DESCRIPTION
256+
257+
B<This program> creates Debian software packages (.deb files) and is a drop-in replacement for dpkg-deb.
258+
259+
=cut

0 commit comments

Comments
 (0)