| Subject: | the XS version doesn't work w/my code when pureperl does. |
Have an util that goes back to 2012. It trims duplicate versions
of downloaded RPMS and saves the latest.
Using pure perl, output looks like:
Show quoted text
> remove-oldver-rpms-in-dir.pl
Read 32742 rpm names.
Use 9 procs w/3639 items/process
#pkgs=20864, #deletes=11878, total=32742
1 additional duplicates found in last pass
Recycling 11879 duplicates...Done
Cumulative This Phase ID
0.000s 0.000s Init
0.000s 0.000s start_program
0.230s 0.230s starting_children
0.233s 0.003s end_starting_children
276.811s 276.578s endRdFrmChldrn_n_start_re_sort
337.756s 60.945s afterFinalSort
340.943s 3.187s afterRecycle
It splits up the task and divides it among multiple processes.
To read the data structs in from the children, they dump the data they worked on and the paran evals the data back in.
The XS version gives:
Show quoted texth> remove-oldver-rpms-in-dir.pl
Read 42 rpm names.
Use 1 procs w/24 items/process
Error in evaluating data: Global symbol "%Data" requires explicit package name at /home/law/bin/remove-oldver-rpms-in-dir.pl line 469, <$mfrh> line 1.
syntax error at /home/law/bin/remove-oldver-rpms-in-dir.pl line 469, near "# line 469 /home/law/bin/remove-oldver-rpms-in-dir.pl
%Data["
at /home/law/bin/remove-oldver-rpms-in-dir.pl line 472, <$mfrh> line 1.
main::read_slave(1, GLOB(0xa97d80), Parse_n_Cmp=HASH(0xa9e310), undef) called at /home/law/bin/remove-oldver-rpms-in-dir.pl line 590
main::read_data_from_children(main=HASH(0x61f210)) called at /home/law/bin/remove-oldver-rpms-in-dir.pl line 705
"Data" should have been an array (@Data).
I did try recompiling D::D just in case something was out of date -- no change.
Attached is some sample data that I eval in the parent when it collects from the child.
Also is the source of the program. Dbg isn't needed (I don't think).
I think any other modules are in cpan.
This does work in pureperl, so I have that option on a separate
line not too far from the top to comment out or not.
Also, I'm not in a hurry to get a solution, since I can use
the perl version though it is a bit slower... :-)
Any Questions, be sure to ask.
Linda
| Subject: | CompVer.pm |
#!/usr/bin/perl
# gvim=:SetNumberAndWidth
use warnings; use strict;
################################################################################
{ package TypeVal;
use warnings; use strict; use mem;
use Data::Vars [qw(type val)];
1}
################################################################################
{ package CompVer;
use warnings; use strict;
our $VERSION='0.0.1';
use mem; use P;
our @EXPORT;
use mem (@EXPORT = qw(cmp_vers));
use Xporter;
use constant { date => 100, num => 75, string => 50,
colon => 4, dash => 4, dot => 3,
};
sub parse_ver ($) {
local $_ = $_[0];
my (@result, $t);
sub addtok;
local *addtok = sub {
push @result, TypeVal->new({type => $t, val => $1 });
$_ = $2;
};
while (length) {
/^(2\d{7})(.*)$/ and $t=date, addtok, next;
/^(\d+)(\W.*)$/ and $t=num, addtok, next;
/^(\d+)$/ and $t=num, addtok, next;
/^(\.)(.*)$/ and $t=dot, addtok, next;
/^([-_])(.*)$/ and $t=dash, addtok, next;
/^(:)(.*)$/ and $t=colon, addtok, next;
/^([^_\.:-]+)(.*)$/ and $t=string, addtok, next;
/^(.+)$/ and $t=string, addtok, next;
}
return @result;
} ## end sub parse_ver ($)
sub cmp_vers($$) {
my ($va, $vb) = @_;
my @pa = parse_ver("$va");
my @pb = parse_ver("$vb");
for (my $i = 0 ; $i < @pa ; ++$i) {
return -1 if $i > @pb;
my ($pat, $pav) = @{$pa[$i]}{qw(type val)};
my ($pbt, $pbv) = @{$pb[$i]}{qw(type val)};
my $cmp;
return $cmp if ($pat >= num && $pbt >= num and $cmp = $pav <=> $pbv) or
$cmp = $pav cmp $pbv;
}
# getting here means at end of pa array;
# if we still have more in pb array then it is longer (and greater)
return @pb > @pa ? 1 : 0;
}
1}
| Subject: | RecycleBin.pm |
#!/usr/bin/perl
{ package RecycleBin;
use warnings; use strict;
use P; use PathCat qw(Sep);
use Cwd;
my $max_warn = 1;
my $warnings = 0;
# gvim=:SetNumberAndWidth
sub getdev_n_path($) {
my $path = $_[0];
my $dev = (stat $path)[0];
return ($dev, $path);
# my $retry=0;
# if ($path =~ m{noarch\.rpm$} ) {
# $path=~ s/noarch\.rpm/src.rpm/; $retry=1 ;
# } elsif ($path =~ m{src\.rpm$} ) {
# $path=~ s/src\.rpm/noarch.rpm/; $retry=1;
# }
#
# if ($retry) {
# ($dev = (stat $path)[0]) and do {
# return ($dev, $path);
# };
# }
# return undef;
}
sub get_partname($) { my $dev = $_[0];
my ($devmaj, $devmin) = ($dev >> 8, $dev & 0xff);
my $devpath = "/sys/dev/block/$devmaj:$devmin";
my $devname;
my ($partname, $partRE);
if (-d pathcat($devpath, "dm")) {
open(my $ph, "<", "/sys/dev/block/$devmaj:$devmin/dm/name") ||
die "can't open volume name: $!\n";
$partname = <$ph>;
chomp $partname;
$partRE = $partname;
while ($partRE =~ m{\w-\w}) {
$partRE =~ s{(\w)-(\w)}{$1.'[-/]'.$2}e;
}
} else {
my $part = readlink $devpath;
$partname = ($part =~ m{([^/]+)$}) ? $1 : undef;
unless ($partname) {
warn "Cannot get partion name from devpath link";
return (undef, undef);
}
$partname = "/dev/" . $partname;
$partRE = $partname;
}
($partname, $partRE)
}
sub get_mnt_point ($) { my $partname = $_[0];
open(my $mh, "<", "/proc/mounts") or die "Can't open /proc/mount: $?\n";
my @table = <$mh>;
my @mps = grep m{$partname}, @table;
die "Cannot find $partname in mount table" if @mps < 1;
my $mnt_pnt = (split /\s+/, $mps[0])[1];
chomp $mnt_pnt;
$mnt_pnt;
}
sub get_recycle_bin($) { my $mnt_pnt = $_[0]; my $recycle_bin;
umask 0;
if (!-d ($recycle_bin = pathcat($mnt_pnt, ".recycle"))) {
mkdir ($recycle_bin, 01777) ||
die "Cannot create recycle bin under mount $mnt_pnt: $!";
chmod 01777, $recycle_bin || die "Cannot set correct mode:$!";
}
$recycle_bin;
}
sub createdest($$) {my ($voldir, $dest) = @_;
umask 0;
use Cwd qw(abs_path);
my @parts = split '/', $dest;
my $curdir = abs_path();
chdir $voldir || die "Cannot create path for recycling @ $voldir";
while (@parts) {
$voldir = pathcat($voldir, shift @parts);
if (! -d $voldir) {
mkdir ($voldir, 01777) || die "Cannot create path @ $voldir: $!";
chmod 01777, $voldir;
chdir $voldir;
}
}
chdir $curdir;
}
our (%dev2partname, %partition2mntpt, %mntdir2recycle);
sub recycle_warn($) { my $msg=$_[0];
++$warnings;
if (--$max_warn) { warn $msg;return undef; } else { die $msg};
}
sub recycle ($) {
my $path = Sep eq substr($_[0],0,1) ? $_[0] : pathcat(getcwd,$_[0]);
my ($dev, $real_path) = getdev_n_path($path);
#/local/suse/tumbleweed/repo/src-non-oss/suse
#/ (src) (7kaa-music-20140929-1.11) .(noarch).rpm
# unless ($dev && $real_path) {
# my ($dirs,$file, $rpmtype, $sfx) = m{^(.*?)/([^/]+?)/([^/.]+?)\.([^/.]+)$};
# Pe "dr=%s, fl=%s, rt=%s, sfx=%s", $dirs,$file, $rpmtype, $sfx;
# my $newpath="$dirs/$file.";
# }
return recycle_warn(
P "real_path=%s(%s), dev=%s", $real_path,
($real_path && -e $real_path? "exists" : "Nexist"), $dev)
unless $dev && $real_path;
my ($partname, $partRE) = $dev2partname{$dev} ||= get_partname($dev);
die "Can't get partname (?$partname?) from dev ($dev)" unless $partname;
my $mnt_pnt = $partition2mntpt{$partname} ||= get_mnt_point($partname);
die "Can't get mntpnt (4 partname $partname)" unless $mnt_pnt;
my $recycle_bin = $mntdir2recycle{$mnt_pnt} ||= get_recycle_bin($mnt_pnt);
my $file = ($real_path =~ m{.*/([^/]+)$})[0];
my $src = $real_path;
$real_path =~ s{$mnt_pnt/}{}; #sub path in recycle bin
my $path_recycle_dir = ($real_path =~ m{(.*)/[^/]+$} ) [0];
my $dst = pathcat($recycle_bin, $path_recycle_dir, $file);
my $recycle_target_dir = pathcat($recycle_bin, $path_recycle_dir);
createdest($recycle_bin, $path_recycle_dir) unless -d $recycle_target_dir;
die P "FAIL -- no target dir %s, in mntpt %s", $recycle_target_dir, $mnt_pnt
unless -d $recycle_target_dir;
if (link $src, $dst) {
unlink $src or recycle_warn(
P "Could not unlink old file %s", $src);
} else {
recycle_warn(P "Could not link %s into %s", $src, $recycle_bin);
}
return !$warnings;
} ## end sub recycle ($)
1}
## vim: ts=2 sw=2 ai
| Subject: | remove-oldver-rpms-in-dir.pl |
Message body is not shown because it is too large.
| Subject: | tmpdata-0 |
Message body not shown because it is not plain text.