initial commit

7 files changed, 627 insertions, 0 deletions

diff --git a/MDK/Common/DataStructure.pm b/MDK/Common/DataStructure.pm
new file mode 100644
index 0000000..8619e03
--- /dev/null
+++ b/MDK/Common/DataStructure.pm
@@ -0,0 +1,42 @@
+package MDK::Common::DataStructure;
+
+use MDK::Common::Math;
+
+
+use vars qw(@ISA %EXPORT_TAGS @EXPORT_OK);
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(ikeys add2hash add2hash_ put_in_hash member invbool listlength strcpy deref is_empty_array_ref is_empty_hash_ref uniq difference2 intersection next_val_in_array list2kv);
+%EXPORT_TAGS = (all => [ @EXPORT_OK ]);
+
+
+sub ikeys { my %l = @_; sort { $a <=> $b } keys %l }
+sub add2hash  { my ($a, $b) = @_; while (my ($k, $v) = each %{$b || {}}) { $a->{$k} ||= $v } $a }
+sub add2hash_ { my ($a, $b) = @_; while (my ($k, $v) = each %{$b || {}}) { exists $a->{$k} or $a->{$k} = $v } $a }
+sub put_in_hash { my ($a, $b) = @_; while (my ($k, $v) = each %{$b || {}}) { $a->{$k} = $v } $a }
+sub member { my $e = shift; foreach (@_) { $e eq $_ and return 1 } 0 }
+sub invbool { my $a = shift; $$a = !$$a; $$a }
+sub listlength { scalar @_ }
+sub strcpy { substr($_[0], $_[2] || 0, length $_[1]) = $_[1] }
+sub deref { ref $_[0] eq "ARRAY" ? @{$_[0]} : ref $_[0] eq "HASH" ? %{$_[0]} : $_[0] }
+
+sub is_empty_array_ref { my $a = shift; !defined $a || @$a == 0 }
+sub is_empty_hash_ref { my $a = shift; !defined $a || keys(%$a) == 0 }
+
+sub uniq { my %l; @l{@_} = (); keys %l }
+sub difference2 { my %l; @l{@{$_[1]}} = (); grep { !exists $l{$_} } @{$_[0]} }
+sub intersection { my (%l, @m); @l{@{shift @_}} = (); foreach (@_) { @m = grep { exists $l{$_} } @$_; %l = (); @l{@m} = (); } keys %l }
+
+
+sub next_val_in_array {
+    my ($v, $l) = @_;
+    my %l = mapn { @_ } $l, [ @$l[1..$#$l], $l->[0] ];
+    $l{$v};
+}
+
+
+sub list2kv { 
+    [ grep_index { MDK::Common::Math::even($::i) } @_ ], 
+    [ grep_index { MDK::Common::Math::odd($::i) } @_ ];
+}
+
+1;
diff --git a/MDK/Common/File.pm b/MDK/Common/File.pm
new file mode 100644
index 0000000..834db33
--- /dev/null
+++ b/MDK/Common/File.pm
@@ -0,0 +1,100 @@
+package MDK::Common::File;
+
+use vars qw(@ISA %EXPORT_TAGS @EXPORT_OK);
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(dirname basename cat_ cat__ output linkf symlinkf renamef touch all glob_ substInFile concat_symlink expand_symlinks openFileMaybeCompressed catMaybeCompressed);
+%EXPORT_TAGS = (all => [ @EXPORT_OK ]);
+
+sub dirname { local $_ = shift; s|[^/]*/*\s*$||; s|(.)/*$|$1|; $_ || '.' }
+sub basename { local $_ = shift; s|/*\s*$||; s|.*/||; $_ }
+sub cat_ { local *F; open F, $_[0] or $_[1] ? die "cat of file $_[0] failed: $!\n" : return; my @l = <F>; wantarray ? @l : join '', @l }
+sub cat__ { my ($f) = @_; my @l = <$f>; wantarray ? @l : join '', @l }
+sub output { my $f = shift; local *F; open F, ">$f" or die "output in file $f failed: $!\n"; print F foreach @_; }
+sub linkf    { unlink $_[1]; link    $_[0], $_[1] }
+sub symlinkf { unlink $_[1]; symlink $_[0], $_[1] }
+sub renamef  { unlink $_[1]; rename  $_[0], $_[1] }
+
+
+sub touch {
+    my ($f) = @_;
+    unless (-e $f) {
+	local *F;
+	open F, ">$f";
+    }
+    my $now = time;
+    utime $now, $now, $f;
+}
+
+
+sub all {
+    my $d = shift;
+
+    local *F;
+    opendir F, $d or return;
+    my @l = grep { $_ ne '.' && $_ ne '..' } readdir F;
+    closedir F;
+
+    @l;
+}
+
+sub glob_ {
+    my ($d, $f) = ($_[0] =~ /\*/) ? (dirname($_[0]), basename($_[0])) : ($_[0], '*');
+
+    $d =~ /\*/ and die "glob_: wildcard in directory not handled ($_[0])\n";
+    ($f = quotemeta $f) =~ s/\\\*/.*/g;
+
+    $d =~ m|/$| or $d .= '/';
+    map { $d eq './' ? $_ : "$d$_" } grep { /^$f$/ } all($d);
+}
+
+
+sub substInFile(&@) {
+    my $f = shift;
+    foreach my $file (@_) {
+	if (-e $file) {
+	    local @ARGV = $file;
+	    local ($^I, $_) = '';
+	    while (<>) { &$f($_); print }
+	} else {
+	    local *F; my $old = select F; # that way eof return true
+	    local $_ = '';
+	    &$f($_);
+	    select $old;
+	    eval { output($file, $_) };
+	}
+    }
+}
+
+
+sub concat_symlink {
+    my ($f, $l) = @_;
+    $l =~ m|^\.\./(/.*)| and return $1;
+
+    $f =~ s|/$||;
+    while ($l =~ s|^\.\./||) { 
+	$f =~ s|/[^/]+$|| or die "concat_symlink: $f $l\n";
+    }
+    "$f/$l";
+}
+sub expand_symlinks {
+    my ($first, @l) = split '/', $_[0];
+    $first eq '' or die "expand_symlinks: $_[0] is relative\n";
+    my ($f, $l);
+    foreach (@l) {
+	$f .= "/$_";
+	$f = concat_symlink($f, "../$l") while $l = readlink $f;
+    }
+    $f;
+}
+
+
+sub openFileMaybeCompressed { 
+    my ($f) = @_;
+    -e $f || -e "$f.gz" or die "file $f not found";
+    local *F;
+    open F, -e $f ? $f : "gzip -dc $f.gz|" or die "file $f is not readable";
+    *F;
+}
+sub catMaybeCompressed { cat__(openFileMaybeCompressed($_[0])) }
+
+1;
diff --git a/MDK/Common/Func.pm b/MDK/Common/Func.pm
new file mode 100644
index 0000000..55277c9
--- /dev/null
+++ b/MDK/Common/Func.pm
@@ -0,0 +1,117 @@
+package MDK::Common::Func;
+
+use MDK::Common::Math;
+
+
+use vars qw(@ISA %EXPORT_TAGS @EXPORT_OK);
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(fold_left mapn mapn_ map_index grep_index find_index map_each grep_each before_leaving catch_cdie cdie);
+%EXPORT_TAGS = (all => [ @EXPORT_OK ]);
+
+
+sub fold_left(&@) {
+    my ($f, $initial, @l) = @_;
+    local ($::a, $::b);
+    $::a = $initial;
+    foreach $::b (@_) { $::a = &$f() }
+    $::a
+}
+
+sub smapn {
+    my $f = shift;
+    my $n = shift;
+    my @r = ();
+    for (my $i = 0; $i < $n; $i++) { push @r, &$f(map { $_->[$i] } @_); }
+    @r
+}
+sub mapn(&@) {
+    my $f = shift;
+    smapn($f, MDK::Common::Math::min(map { scalar @$_ } @_), @_);
+}
+sub mapn_(&@) {
+    my $f = shift;
+    smapn($f, MDK::Common::Math::max(map { scalar @$_ } @_), @_);
+}
+
+
+sub map_index(&@) {
+    my $f = shift;
+    my @v; local $::i = 0;
+    map { @v = &$f($::i); $::i++; @v } @_;
+}
+sub grep_index(&@) {
+    my $f = shift;
+    my $v; local $::i = 0;
+    grep { $v = &$f($::i); $::i++; $v } @_;
+}
+sub find_index(&@) {
+    my $f = shift;
+    local $_;
+    for (my $i = 0; $i < @_; $i++) {
+	$_ = $_[$i];
+	&$f and return $i;
+    }
+    die "find_index failed in @_";
+}
+sub map_each(&%) {
+    my ($f, %h) = @_;
+    my @l;
+    local ($::a, $::b);
+    while (($::a, $::b) = each %h) { push @l, &$f($::a, $::b) }
+    @l;
+}
+sub grep_each(&%) {
+    my ($f, %h) = @_;
+    my %l;
+    local ($::a, $::b);
+    while (($::a, $::b) = each %h) { $l{$::a} = $::b if &$f($::a, $::b) }
+    %l;
+}
+
+
+sub add_f4before_leaving {
+    my ($f, $b, $name) = @_;
+
+    unless ($MDK::Common::Func::before_leaving::{$name}) {
+	no strict 'refs';
+	${"MDK::Common::Func::before_leaving::$name"} = 1;
+	${"MDK::Common::Func::before_leaving::list"} = 1;
+    }
+    local *N = *{$MDK::Common::Func::before_leaving::{$name}};
+    my $list = *MDK::Common::Func::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 {}, 'MDK::Common::Func::before_leaving';
+    add_f4before_leaving($f, $b, 'DESTROY');
+    $b;
+}
+
+sub catch_cdie(&&) {
+    my ($f, $catch) = @_;
+
+    local @MDK::Common::Func::cdie_catches;
+    unshift @MDK::Common::Func::cdie_catches, $catch;
+    &$f();
+}
+
+sub cdie {
+    my ($err, $f) = @_;
+    foreach (@MDK::Common::Func::cdie_catches) {
+	$@ = $err;
+	&{$_}(\$err) and return;
+    }
+    die $err;
+}
+
+1;
+
diff --git a/MDK/Common/Math.pm b/MDK/Common/Math.pm
new file mode 100644
index 0000000..5b46f29
--- /dev/null
+++ b/MDK/Common/Math.pm
@@ -0,0 +1,65 @@
+package MDK::Common::Math;
+
+use vars qw(@ISA %EXPORT_TAGS @EXPORT_OK $PRECISION $PI);
+@ISA = qw(Exporter);
+@EXPORT_OK = qw($PI even odd sqr sign round round_up round_down divide min max or_ and_ sum product factorize decimal2fraction poly2);
+%EXPORT_TAGS = (all => [ @EXPORT_OK ]);
+
+
+$PRECISION = 10;
+$PI = 3.1415926535897932384626433832795028841972;
+
+sub even { $_[0] % 2 == 0 }
+sub odd  { $_[0] % 2 == 1 }
+sub sqr  { $_[0] * $_[0] }
+sub sign { $_[0] <=> 0 }
+sub round { int ($_[0] + 0.5) }
+sub round_up { my ($i, $r) = @_; $i = int $i; $i += $r - ($i + $r - 1) % $r - 1; }
+sub round_down { my ($i, $r) = @_; $i = int $i; $i -= $i % $r; }
+sub divide { my $d = int $_[0] / $_[1]; wantarray ? ($d, $_[0] % $_[1]) : $d }
+sub min { my $n = shift; $_ < $n and $n = $_ foreach @_; $n }
+sub max { my $n = shift; $_ > $n and $n = $_ foreach @_; $n }
+sub or_ { my $n = 0; $n ||= $_ foreach @_; $n }
+sub and_{ my $n = 1; $n &&= $_ foreach @_; $n }
+sub sum { my $n = 0; $n  += $_ foreach @_; $n }
+sub product { my $n = 1; $n  *= $_ foreach @_; $n }
+
+
+sub factorize {
+    my ($n) = @_;
+    my @r = ();
+
+    $n == 1 and return [ 1, 1 ];
+    for (my $k = 2; sqr($k) <= $n; $k++) {
+	my $i = 0;
+	for ($i = 0; $n % $k == 0; $i++) { $n /= $k; }
+	$i and push @r, [ $k, $i ];
+    }
+    $n > 1 and push @r, [ $n, 1 ];
+    @r;
+}
+
+sub decimal2fraction { # ex: 1.33333333 -> (4, 3)
+    my $n0 = shift;
+    my $precision = 10 ** -(shift || $PRECISION);
+    my ($a, $b) = (int $n0, 1);
+    my ($c, $d) = (1, 0);
+    my $n = $n0 - int $n0;
+    my $k;
+    until (abs($n0 - $a / $c) < $precision) {
+	$n = 1 / $n;
+	$k = int $n;
+	($a, $b) = ($a * $k + $b, $a);
+	($c, $d) = ($c * $k + $d, $c);
+	$n -= $k;
+    }
+    ($a, $c)
+}
+
+sub poly2 {
+    my ($a, $b, $c) = @_;
+    my $d = ($b**2 - 4 * $a * $c) ** 0.5;  
+    (-$b + $d) / 2 / $a, (-$b - $d) / 2 / $a
+}
+
+1;
diff --git a/MDK/Common/String.pm b/MDK/Common/String.pm
new file mode 100644
index 0000000..74b8e2b
--- /dev/null
+++ b/MDK/Common/String.pm
@@ -0,0 +1,90 @@
+package MDK::Common::String;
+
+use vars qw(@ISA %EXPORT_TAGS @EXPORT_OK);
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(bestMatchSentence formatList formatError formatTimeRaw formatLines formatAlaTeX warp_text);
+%EXPORT_TAGS = (all => [ @EXPORT_OK ]);
+
+
+# count the number of character that match
+sub bestMatchSentence {
+
+    my $best = -1;
+    my $bestSentence;
+    my @s = split /\W+/, shift;
+    foreach (@_) {
+	my $count = 0;
+	foreach my $e (@s) {
+	    $count+= length ($e) if /^$e$/;
+	    $count+= length ($e) if /^$e$/i;
+	    $count+= length ($e) if /$e/;
+	    $count+= length ($e) if /$e/i;
+	}
+	$best = $count, $bestSentence = $_ if $count > $best;
+    }
+    wantarray ? ($bestSentence, $best) : $bestSentence;
+}
+
+
+sub formatList {
+    my $nb = shift;
+    join(", ", @_ <= $nb ? @_ : (@_[0..$nb-1], '...'));
+}
+sub formatError {
+    my ($err) = @_;
+    $err =~ s/ at .*?$/\./ if !$::testing;
+    $err;
+}
+sub formatTimeRaw {
+    my ($s, $m, $h) = gmtime($_[0]);
+    sprintf "%d:%02d:%02d", $h, $m, $s;
+}
+sub formatLines {
+    my ($t, $tmp);
+    foreach (split "\n", $_[0]) {
+	if (/^\s/) {
+	    $t .= "$tmp\n";
+	    $tmp = $_;
+	} else {
+	    $tmp = ($tmp ? "$tmp " : ($t && "\n") . $tmp) . $_;
+	}
+    }
+    "$t$tmp\n";
+}
+sub formatAlaTeX {
+    my ($t, $tmp);
+    foreach (split "\n", $_[0]) {
+	if (/^$/) {
+	    $t .= ($t && "\n") . $tmp;
+	    $tmp = '';
+	} else {
+	    $tmp = ($tmp && "$tmp ") . (/^\s*(.*?)\s*$/)[0];
+	}
+    }
+    $t . ($t && $tmp && "\n") . $tmp;
+}
+
+
+
+
+sub warp_text {
+    my ($text, $width) = @_;
+    $width ||= 80;
+
+    my @l;
+    foreach (split "\n", $text) {
+	my $t = '';
+	foreach (split /\s+/, $_) {
+	    if (length "$t $_" > $width) {
+		push @l, $t;
+		$t = $_;
+	    } else {
+		$t = "$t $_";
+	    }
+	}
+	push @l, $t;
+    }
+    @l;
+}
+
+1;
diff --git a/MDK/Common/System.pm b/MDK/Common/System.pm
new file mode 100644
index 0000000..c8c4535
--- /dev/null
+++ b/MDK/Common/System.pm
@@ -0,0 +1,181 @@
+package MDK::Common::System;
+
+use MDK::Common::Math;
+use MDK::Common::File;
+
+
+use vars qw(@ISA %EXPORT_TAGS @EXPORT_OK %compat_arch $printable_chars $sizeof_int $bitof_int); #);
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(%compat_arch $printable_chars $sizeof_int $bitof_int typeFromMagic list_passwd list_home list_skels syscall_ df sync psizeof availableMemory availableRamMB gettimeofday unix2dos getVarsFromSh setVarsInSh setVarsInShMode setVarsInCsh template2file template2userfile update_userkderc); #);
+%EXPORT_TAGS = (all => [ @EXPORT_OK ]);
+
+
+%compat_arch = ( #- compatibilty arch mapping.
+		     'noarch'  => undef,
+		     'ia32'    => 'noarch',
+		     'i386'    => 'ia32',
+		     'i486'    => 'i386',
+		     'i586'    => 'i486',
+		     'i686'    => 'i586',
+		     'i786'    => 'i686',
+		     'k6'      => 'i586',
+		     'k7'      => 'k6',
+		     'k8'      => 'k7',
+		     'ia64'    => 'noarch',
+		     'ppc'     => 'noarch',
+		     'alpha'   => 'noarch',
+		     'sparc'   => 'noarch',
+		     'sparc32' => 'sparc',
+		     'sparc64' => 'sparc32',
+		     'ia64'    => 'noarch',
+		   );
+
+$printable_chars = "\x20-\x7E";
+$sizeof_int      = psizeof("i");
+$bitof_int       = $sizeof_int * 8;
+
+sub typeFromMagic {
+    my $f = shift;
+    local *F; sysopen F, $f, 0 or return;
+
+    my $tmp;
+  M: foreach (@_) {
+	my ($name, @l) = @$_;
+	while (@l) {
+	    my ($offset, $signature) = splice(@l, 0, 2);
+	    sysseek(F, $offset, 0) or next M;
+	    sysread(F, $tmp, length $signature);
+	    $tmp eq $signature or next M;
+	}
+	return $name;
+    }
+    undef;
+}
+
+
+sub list_passwd() {
+    my (@l, @e);
+    setpwent();
+    while (@e = getpwent()) { push @l, [ @e ] }
+    endpwent();
+    @l;
+}
+sub list_home() {
+    map { $_->[7] } grep { $_->[2] >= 500 } list_passwd();
+}
+sub list_skels { 
+    my ($prefix, $suffix) = @_;
+    grep { -d $_ && -w $_ } map { "$prefix$_/$suffix" } '/etc/skel', '/root', list_home();
+}
+
+
+
+sub syscall_ {
+    my $f = shift;
+
+    require 'syscall.ph';
+    syscall(&{$common::{"SYS_$f"}}, @_) == 0;
+}
+
+
+#- return the size of the partition and its free space in KiB
+sub df {
+    my ($mntpoint) = @_;
+    my ($blocksize, $size, $free);
+    my $buf = ' ' x 20000;
+    syscall_('statfs', $mntpoint, $buf) or return;
+    (undef, $blocksize, $size, $free, undef, undef) = unpack "L!6", $buf;
+    map { $_ * ($blocksize / 1024) } $size, $free;
+}
+
+sub sync { syscall_('sync') }
+sub psizeof { length pack $_[0] }
+sub availableMemory() { MDK::Common::Math::sum(map { /(\d+)/ } grep { /^(MemTotal|SwapTotal):/ } MDK::Common::File::cat_("/proc/meminfo")); }
+sub availableRamMB() { 4 * MDK::Common::Math::round((-s '/proc/kcore') / 1024 / 1024 / 4); }
+sub gettimeofday { my $t = pack "LL"; syscall_('gettimeofday', $t, 0) or die "gettimeofday failed: $!\n"; unpack("LL", $t) }
+sub unix2dos { local $_ = $_[0]; s/\015$//mg; s/$/\015/mg; $_ }
+
+
+
+sub getVarsFromSh {
+    my %l;
+    local *F; open F, $_[0] or return;
+    local $_;
+    while (<F>) {
+	s/#.*//; # remove comments
+	my ($v, $val, $val2) =
+	  /^\s*			# leading space
+	   (\w+) =		# variable
+	   (
+   	       "([^"]*)"	# double-quoted text
+   	     | '([^']*)'	# single-quoted text
+   	     | [^'"\s]+		# normal text
+           )
+           \s*$			# end of line
+          /x or next;
+	$l{$v} = defined $val2 ? $val2 : $val;
+    }
+    %l;
+}
+
+sub setVarsInSh {
+    my ($file, $l, @fields) = @_;
+    setVarsInShMode($file, 0777 ^ umask(), $l, @fields);
+}
+
+sub setVarsInShMode {
+    my ($file, $mod, $l, @fields) = @_;
+    @fields = keys %$l unless @fields;
+
+    local *F;
+    open F, "> $file" or die "cannot create config file $file";
+    chmod $mod, $file;
+    $l->{$_} and print F "$_=$l->{$_}\n" foreach @fields;
+}
+
+sub setVarsInCsh {
+    my ($file, $l, @fields) = @_;
+    @fields = keys %$l unless @fields;
+
+    local *F;
+    open F, "> $_[0]" or die "cannot create config file $file";
+    $l->{$_} and print F "setenv $_ $l->{$_}\n" foreach @fields;
+}
+
+sub template2file {
+    my ($in, $out, %toreplace) = @_;
+    output $out, map { s/@@@(.*?)@@@/$toreplace{$1}/g; $_ } MDK::Common::File::cat_($in);
+}
+sub template2userfile {
+    my ($prefix, $in, $out_rel, $force, %toreplace) = @_;
+
+    foreach (list_skels($prefix, $out_rel)) {
+	-d MDK::Common::File::dirname($_) or !-e $_ or $force or next;
+
+	template2file($in, $_, %toreplace);
+	m|/home/(.+?)/| and chown(getpwnam($1), getgrnam($1), $_);
+    }
+}
+sub update_userkderc {
+    my ($file, $category, %subst) = @_;
+
+    output $file,
+      (map {
+	  my $l = $_;
+	  s/^\s*//;
+	  if (my $i = /^\[$category\]/i ... /^\[/) {
+	      if ($i =~ /E/) { #- for last line of category
+		  $l = join('', map_each { "$::a=$::b\n" } %subst) . $l;
+		  %subst = ();
+	      } elsif (/^(\w*?)=/) {
+		  if (my $e = delete $subst{lc($1)}) {
+		      $l = "$1=$e\n";
+		  }
+	      }
+	  }
+	  $l;
+      } MDK::Common::File::cat_($file)),
+	(%subst && "[$category]\n", map_each { "$::a=$::b\n" } %subst); #- if category has not been found above.
+}
+
+1;
diff --git a/MDK/Common/Various.pm b/MDK/Common/Various.pm
new file mode 100644
index 0000000..b012343
--- /dev/null
+++ b/MDK/Common/Various.pm
@@ -0,0 +1,32 @@
+package MDK::Common::Various;
+
+use vars qw(@ISA %EXPORT_TAGS @EXPORT_OK);
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(first second top bool to_int to_float bool2text bool2yesno text2bool chomp_ backtrace);
+%EXPORT_TAGS = (all => [ @EXPORT_OK ]);
+
+
+sub first { $_[0] }
+sub second { $_[1] }
+sub top { $_[-1] }
+
+sub bool { $_[0] ? 1 : 0 }
+sub to_int { $_[0] =~ /(\d*)/; $1 }
+sub to_float { $_[0] =~ /(\d*(\.\d*)?)/; $1 }
+sub bool2text { $_[0] ? "true" : "false" }
+sub bool2yesno { $_[0] ? "yes" : "no" }
+sub text2bool { my $t = lc($_[0]); $t eq "true" || $t eq "yes" ? 1 : 0 }
+
+sub chomp_ { my @l = map { my $l = $_; chomp $l; $l } @_; wantarray ? @l : $l[0] }
+
+sub backtrace {
+    my $s;
+    for (my $i = 1; caller($i); $i++) {
+	my ($package, $file, $line, $func) = caller($i);
+	$s .= "$func() called from $file:$line\n";
+    }
+    $s;
+}
+
+1;
+