From a460867f4ecfe6deb7daa74d191289a667c2ade5 Mon Sep 17 00:00:00 2001
From: Gerhard Gonter <ggonter@gmail.com>
Date: Tue, 9 Aug 2022 14:32:57 +0200
Subject: [PATCH] moved mkdeb.pl from git repo "deb-pkg-hacks"
---
scripts/mkdeb.pl | 80 ++++++++++
scripts/pmlnk.pl | 399 -----------------------------------------------
2 files changed, 80 insertions(+), 399 deletions(-)
create mode 100755 scripts/mkdeb.pl
delete mode 100755 scripts/pmlnk.pl
diff --git a/scripts/mkdeb.pl b/scripts/mkdeb.pl
new file mode 100755
index 0000000..b6eb47e
--- /dev/null
+++ b/scripts/mkdeb.pl
@@ -0,0 +1,80 @@
+#!/usr/bin/perl
+
+use strict;
+
+my $pkg_base= $ENV{PKGBASE} || '~/tmp/pkg';
+
+while (my $arg= shift (@ARGV))
+{
+ mk_package_by_path($arg);
+}
+
+sub mk_package_by_path
+{
+ my $arg= shift;
+
+ my @parts= split('/', $arg);
+ my $pkg_version= pop(@parts);
+ my $pkg_epoch= pop(@parts);
+ my $pkg_name= pop(@parts);
+ my $base= join('/', @parts);
+
+ mk_package($base, $pkg_name, $pkg_epoch, $pkg_version);
+}
+
+sub cmd
+{
+ my @c= @_;
+
+ print "cmd: [", join(' ', @c), "]\n";
+ system (@c);
+}
+
+sub mk_package
+{
+ my $base= shift;
+ my $pkg_name= shift;
+ my $pkg_epoch= shift;
+ my $pkg_version= shift;
+
+ my $deb= '../../../'. $pkg_name . '-';
+ $deb .= $pkg_epoch.':' if ($pkg_epoch > 0);
+ $deb .= $pkg_version .'.deb';
+ print __LINE__, " deb=[$deb]\n";
+
+ chdir($base) or die "base not found [$base]";
+ chdir($pkg_name) or die "pkg_name not found [$pkg_name]";
+ chdir($pkg_epoch) or die "pkg_epoch not found [$pkg_epoch]";
+ chdir($pkg_version) or die "pkg_version not found [$pkg_version]";
+
+ # mk_md5sums();
+ unlink('control.tar.xz');
+ unlink('data.tar.xz');
+
+ cmd("(cd data && find [a-z]* -type f -print | xargs md5sum) >control/md5sums");
+ cmd('(cd control && tar -cf ../control.tar .)');
+ cmd('(cd data && tar -cf ../data.tar .)');
+
+ cmd(qw(xz -zv control.tar data.tar));
+
+ # the ar file must contain these fils in this order
+ cmd('ar', 'rcSv', $deb, 'debian-binary');
+ cmd('ar', 'rcSv', $deb, 'control.tar.xz');
+ cmd('ar', 'rcSv', $deb, 'data.tar.xz');
+
+ chdir('..');
+ chdir('..');
+ chdir('..');
+}
+
+sub mk_md5sums
+{
+ # my $dir= shift;
+
+ # my $ddir= join('/', $dir, 'data');
+ # chdir('data') or die;
+
+ cmd("(cd data && find [a-z]* -type f -print | xargs md5sum) >control/md5sums");
+ # chdir('..');
+}
+
diff --git a/scripts/pmlnk.pl b/scripts/pmlnk.pl
deleted file mode 100755
index 12e2950..0000000
--- a/scripts/pmlnk.pl
+++ /dev/null
@@ -1,399 +0,0 @@
-#!/usr/bin/perl
-
-=head1 NAME
-
- pmlnk -- Perl Module Link
-
-=cut
-
-use strict;
-
-package pmlnk;
-
-use Data::Dumper;
-$Data::Dumper::Indent= 1;
-
-__PACKAGE__->main() unless caller();
-
-sub main
-{
- # print __LINE__, " caller: ", join(' ', caller()), "\n";
-
- my @dirs= ();
- my $target;
- my $pkg_list;
- my %par= ( op_mode => 'link' );
- while (my $arg= shift (@ARGV))
- {
- # print __LINE__, " arg=[$arg]\n";
-
- if ($arg eq '--') { push (@dirs, @ARGV); @ARGV= (); }
- elsif ($arg =~ /^--(.+)/)
- {
- my ($opt, $val)= split ('=', $1, 2);
- if ($opt eq 'help') { usage(); }
- elsif ($opt eq 'copy') { $par{op_mode}= 'copy'; }
- elsif ($opt eq 'force' || $opt eq 'overwrite') { $par{force}= 1; }
- elsif ($opt eq 'link') { $par{op_mode}= 'link'; }
- elsif ($opt eq 'packages') { $pkg_list= shift(@ARGV); }
- elsif ($opt eq 'target') { $target= shift(@ARGV); }
- else { usage(); }
- }
- elsif ($arg =~ /^-(.+)/)
- {
- foreach my $opt (split ('', $1))
- {
- if ($opt eq 'h') { usage(); exit (0); }
- # elsif ($opt eq 'x') { $x_flag= 1; }
- else { usage(); }
- }
- }
- else
- {
- push (@dirs, $arg);
- }
- }
-
- push (@dirs, '.') unless (@dirs);
-
- $par{pkg_list}= read_items($pkg_list) if (defined ($pkg_list));
- my $pmlnk= pmlnk->new( %par );
-
- # print __LINE__, " dirs: ", join(' ', @dirs), "\n";
- foreach my $dir (@dirs)
- {
- # print __LINE__, " dir=[$dir]\n";
- my $pm_files= $pmlnk->find_modules($dir, 'pm');
- # print __LINE__, " pm_files: ", join(' ', @$pm_files), "\n";
- $pmlnk->check_module_list(@$pm_files);
- }
-
- if (defined ($target))
- {
- $pmlnk->make_links_or_copies($target)
- }
- else
- {
- print __LINE__, " pmlnk: ", Dumper($pmlnk);
- }
-}
-
-sub usage
-{
- system ($0);
-}
-
-sub new
-{
- my $class= shift;
-
- my $self=
- {
- @_,
- files => [],
- modules => [],
- };
- bless $self, $class;
- # print __LINE__, " self: ", Dumper($self); exit;
-}
-
-sub find_modules
-{
- my $self= shift;
- my $path= shift;
- my $extension= shift || 'pm';
-
- my @dirs= ($path);
- my $files= $self->{files};
- my @new_files= ();
- DIR: while (my $dir= shift (@dirs))
- {
- unless ($dir =~ m#^/#)
- {
- $dir= undef if ($dir eq '.');
- while ($dir=~ s#^\.\/##) {}
- die "don't do that [$dir]" if ($dir eq '..' || $dir =~ m#^\.\.\/#);
- my $pwd= `pwd`;
- chop($pwd);
- $dir= (defined ($dir) && $dir ne '') ? join('/', $pwd, $dir) : $pwd;
- }
- opendir(DIR, $dir) or die;
- # print __LINE__, " reading dir [$dir]\n";
-
- ENTRY: while (my $e= readdir(DIR))
- {
- next ENTRY if ($e eq '.' || $e eq '..');
- next ENTRY if ($e eq '.git' || $e eq '.svn' || $e eq 'CVS');
-
- my $fp= join('/', $dir, $e);
- # print __LINE__, " e=[$e] fp=[$fp]\n";
- # my @st= stat($fp);
- if (-d $fp)
- {
- push(@dirs, $fp);
- }
- elsif (-f $fp)
- {
- my @e= split(/\./, $e);
- my $ext= pop (@e);
- # print __LINE__, " e=[$e] ext=[$ext]\n";
- if ($ext eq $extension)
- {
- push (@$files, $fp);
- push (@new_files, $fp);
- }
- }
- }
- closedir(DIR);
- }
-
- (wantarray) ? @new_files : \@new_files;
-}
-
-sub check_module_list
-{
- my $self= shift;
- my @pm_files= @_;
-
- my $modules= $self->{modules};
- foreach my $pm_file (@pm_files)
- {
- my $info= $self->check_module ($pm_file);
- # print __LINE__, " pm_file=[$pm_file] info: ", Dumper($info);
- push (@$modules, $info);
- }
-}
-
-sub check_module
-{
- my $self= shift;
- my $fnm= shift;
-
- open (F, '<:utf8', $fnm) or die;
- my @packages= ();
- my @uses= ();
- while (<F>)
- {
- chop;
- push (@packages, $1) if (m#^\s*package\s*([\w\d:_]+)[\(\); ]#);
- push (@uses, $1) if (m#^\s*use\s*([\w\d:_]+)[\(\); ]#);
- }
- close (F);
-
- my $info=
- {
- filename => $fnm,
- packages => \@packages,
- uses => \@uses,
- };
-
- # find out, which package name matches filename
- my @fnm= reverse split(/\//, $fnm);
- foreach my $pkg (@packages)
- {
- next if ($pkg eq 'strict' || $pkg eq 'warnings');
- my @pkg= reverse split('::', $pkg);
- $pkg[0] .= '.pm';
- # print __LINE__, " pkg=[$pkg] pkg-list: ", join(' ', @pkg), "\n";
- my $match= 1;
- M: for (my $i= 0; $i <= $#pkg; $i++) { if ($pkg[$i] ne $fnm[$i]) { $match= 0; last M; } }
- if ($match)
- {
- # print __LINE__, " match: $fnm == $pkg\n";
- $info->{matching_package_name}= $pkg;
- }
- }
-
- $info;
-}
-
-sub make_links_or_copies
-{
- my $self= shift;
- my $target= shift;
-
- # create target path
- {
- my @target= split('/', $target);
- my @new_target;
- foreach my $t (@target)
- {
- next if ($t eq '.');
- if ($t eq '..')
- { # TODO: maybe we should care for an empty directory in the target
- pop(@new_target);
- next;
- }
- push(@new_target, $t);
- mk_dir(join('/', @new_target));
- }
- $target= join('/', @new_target);
- }
-
- my $op_mode= ($self->{op_mode} eq 'copy') ? 1 : 0;
- my $force= (exists($self->{force}) && $self->{force}) ? 1 : 0;
-
- my $check_package_list= 0;
- my %pkg_list;
- if (exists ($self->{pkg_list}))
- {
- my @pkg_list= @{$self->{pkg_list}};
- die " empty package list!" unless (@pkg_list);
- %pkg_list= map { $_ => 1 } @pkg_list;
- $check_package_list= 1;
- }
-
- my $modules= $self->{modules};
- MODULE: foreach my $module (@$modules)
- {
- # print __LINE__, " module: ", Dumper($module);
- my $pkg_name= $module->{matching_package_name};
- unless ($pkg_name)
- {
- print "ATTN: no matching_package_name detected!\n";
- print __LINE__, " module: ", Dumper($module);
- next MODULE;
- }
-
- next if ($check_package_list && !$pkg_list{$pkg_name});
-
- my @pkg_name= split('::', $pkg_name);
- my $module_name= pop(@pkg_name);
- my $t_path= $target;
-
- while (my $t_dir= shift (@pkg_name))
- {
- $t_path .= '/'. $t_dir;
- mk_dir($t_path);
- }
- $t_path .= '/'. $module_name . '.pm';
-
- if ($op_mode)
- {
- mk_copy($module->{filename}, $t_path, $force);
- }
- else
- {
- mk_link($module->{filename}, $t_path, $force);
- }
- }
-}
-
-=head1 Internal Functions
-
-=head2 mk_dir($path)
-
-=cut
-
-sub mk_dir
-{
- my $path= shift;
- if ($path && !-d $path)
- {
- print "creating [$path]\n";
- mkdir($path);
- }
-}
-
-sub mk_link
-{
- my $src= shift;
- my $dst= shift;
- my $force= shift;
-
- if (-l $dst)
- {
- my $lnk= readlink($dst);
- if ($src eq $lnk) { } # ignore, that's the same thing
- else
- {
- print "different symlink already exists\n";
- print "dst=[$dst]\n";
- print "src=[$src]\n";
- print "lnk=[$lnk]\n";
- if ($force)
- {
- unlink($dst);
- goto LINK;
- }
- }
- }
- elsif (-f $dst)
- {
- print "ATTN: symlink [$dst] already exists as file!\n";
- if ($force)
- {
- unlink($dst);
- goto LINK;
- }
- }
- else
- {
-LINK:
- print "symlinking $dst -> $src\n";
- symlink($src, $dst);
- }
-}
-
-sub mk_copy
-{
- my $src= shift;
- my $dst= shift;
- my $force= shift;
-
- if (-l $dst)
- {
- my $lnk= readlink($dst);
- print "ATTN: exists as symlink:\n";
- print "lnk=[$lnk]\n";
- if ($force)
- {
- unlink ($dst);
- goto COPY;
- }
- }
- elsif (-f $dst)
- {
- print "ATTN: file [$dst] already exists!\n";
- goto COPY if ($force);
- }
- else
- {
-COPY:
- print "copying $src to $dst\n";
- copy_file($src, $dst);
- }
-}
-
-sub copy_file
-{
- my $src= shift;
- my $dst= shift;
-
- open (FI, '<:raw', $src) or die "can't read source [$src]";
- open (FO, '>:raw', $dst) or die "can't write to destination [$dst]";
- my $buffer;
- while (1)
- {
- my $cnt= sysread(FI, $buffer, 64*1024);
- last unless ($cnt > 0);
- syswrite(FO, $buffer);
- }
- close(FO);
- close(FI);
-}
-
-sub read_items
-{
- my $fnm= shift;
- open (FI, '<:utf8', $fnm) or die "can't read item list [$fnm]";
- my @list;
- while (<FI>)
- {
- chop;
- next if (m/^#/ || m/^\s*$/);
- push (@list, $_);
- }
- close(FI);
- \@list;
-}
--
GitLab