summaryrefslogtreecommitdiffstats
path: root/perl-install/common.pm
diff options
context:
space:
mode:
Diffstat (limited to 'perl-install/common.pm')
-rw-r--r--perl-install/common.pm57
1 files changed, 54 insertions, 3 deletions
diff --git a/perl-install/common.pm b/perl-install/common.pm
index 449efb922..90b02b82a 100644
--- a/perl-install/common.pm
+++ b/perl-install/common.pm
@@ -7,9 +7,9 @@ use vars qw(@ISA %EXPORT_TAGS @EXPORT_OK $printable_chars $sizeof_int $bitof_int
@ISA = qw(Exporter);
%EXPORT_TAGS = (
common => [ qw(__ min max sum sign product bool ikeys member divide is_empty_array_ref add2hash set_new set_add round_up round_down first second top uniq translate untranslate warp_text) ],
- functional => [ qw(fold_left difference2) ],
+ functional => [ qw(fold_left difference2 before_leaving catch_cdie cdie) ],
file => [ qw(dirname basename touch all glob_ cat_ chop_ mode) ],
- system => [ qw(sync makedev unmakedev psizeof strcpy gettimeofday syscall_ crypt_ getVarsFromSh) ],
+ system => [ qw(sync makedev unmakedev psizeof strcpy gettimeofday syscall_ crypt_ getVarsFromSh setVarsInSh) ],
constant => [ qw($printable_chars $sizeof_int $bitof_int $SECTORSIZE) ],
);
@EXPORT_OK = map { @$_ } values %EXPORT_TAGS;
@@ -49,7 +49,7 @@ sub is_empty_array_ref { my $a = shift; !defined $a || @$a == 0 }
sub difference2 { my %l; @l{@{$_[1]}} = (); grep { !exists $l{$_} } @{$_[0]} }
sub set_new(@) { my %l; @l{@_} = undef; { list => [ @_ ], hash => \%l } }
-sub set_add($@) { my $o = shift; foreach (@_) { exists $o->{hash}->{$_} and next; push @{$o->{list}}, $_; $o->{hash}->{$_} = undef } }
+sub set_add($@) { my $o = shift; foreach (@_) { exists $o->{hash}{$_} and next; push @{$o->{list}}, $_; $o->{hash}{$_} = undef } }
sub sync { syscall_('sync') }
sub gettimeofday { my $t = pack "LL"; syscall_('gettimeofday', $t, 0) or die "gettimeofday failed: $!\n"; unpack("LL", $t) }
@@ -75,6 +75,50 @@ sub fold_left(&$@) {
$a
}
+sub add_f4before_leaving {
+ my ($f, $b, $name) = @_;
+
+# print "add_f4before_leaving\n";
+ unless ($common::before_leaving::{$name}) {
+ no strict 'refs';
+ ${"common::before_leaving::$name"} = 1;
+ ${"common::before_leaving::list"} = 1;
+ }
+ local *N = *{$common::before_leaving::{$name}};
+ my $list = *common::before_leaving::list;
+ $list->{$b}{$name} = $f;
+ *N = sub {
+ my $f = $list->{$_[0]}{$name} or die;
+ $name eq 'DESTROY' and delete $list->{$_[0]};
+ goto $f;
+ } unless defined &{*N};
+
+}
+
+# ! the functions are not called in the order wanted, in case of multiple before_leaving :(
+sub before_leaving(&) {
+ my ($f) = @_;
+ my $b = bless {}, 'common::before_leaving';
+ add_f4before_leaving($f, $b, 'DESTROY');
+ $b;
+}
+
+sub catch_cdie(&&) {
+ my ($f, $catch) = @_;
+
+ unshift @common::cdie_catches, $catch;
+ &$f();
+ shift @common::cdie_catches;
+}
+
+sub cdie {
+ $@ = join '', @_;
+ foreach (@common::cdie_catches) {
+ print;
+ &{$_}(@_) and return;
+ }
+ die @_;
+}
sub all {
my $d = shift;
@@ -164,3 +208,10 @@ sub getVarsFromSh($) {
}
%l;
}
+
+sub setVarsInSh {
+ my ($file, $l, @fields) = @_;
+ local *F;
+ open F, "> $_[0]" or die "cannot create config file $file";
+ $l->{$_} and print F "$_=$l->{$_}\n" foreach @fields;
+}