Girocco/Dumper.pm

   1 # Girocco::Dumper.pm -- Installation Utility Dumper Functions
   2 # Copyright (C) 2020,2021 Kyle J. McKay.  All rights reserved.
   3
   4 # This program is free software; you can redistribute it and/or
   5 # modify it under the terms of the GNU General Public License
   6 # as published by the Free Software Foundation; either version 2
   7 # of the License, or (at your option) any later version.
   8 #
   9 # This program is distributed in the hope that it will be useful,
  10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 # GNU General Public License for more details.
  13 #
  14 # You should have received a copy of the GNU General Public License
  15 # along with this program; if not, write to the Free Software
  16 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
  17
  18 {package _Girocco::Dumper::HashLog;
  19
  20 use strict;
  21 use warnings;
  22
  23 use Tie::Hash ();
  24 use base qw(Tie::ExtraHash);
  25
  26 sub TIEHASH {
  27         my $class = shift;
  28         my $hr = $_[0];
  29         ref($hr) eq 'HASH' or $hr = {};
  30         my $self = bless([$hr, {}], $class);
  31         return $self;
  32 }
  33
  34 sub STORE {
  35         my $self = shift;
  36         ${$$self[1]}{$_[0]} = [$_[1]];
  37         $self->SUPER::STORE(@_);
  38 }
  39
  40 sub DELETE {
  41         my $self = shift;
  42         ${$$self[1]}{$_[0]} = [];
  43         $self->SUPER::DELETE(@_);
  44 }
  45
  46 }
  47
  48 package Girocco::Dumper;
  49
  50 use strict;
  51 use warnings;
  52
  53 use base qw(Exporter);
  54 our ($VERSION, @EXPORT, @EXPORT_OK);
  55
  56 BEGIN {
  57         @EXPORT = qw();
  58         @EXPORT_OK = qw(RequireENV Dump DumpENV Boilerplate Scalars FreezeConfig GetConfPath);
  59         *VERSION = \'1.0';
  60 }
  61
  62 use B ();
  63 use Data::Dumper ();
  64
  65 my $_sortkeys;
  66 BEGIN {$_sortkeys = sub {
  67         package _Girocco::Dumper;
  68         sort({uc($a) cmp uc($b) || $a cmp $b} keys(%{$_[0]}));
  69 }}
  70
  71 my $_dumpit;
  72 BEGIN {$_dumpit = sub {
  73         my $d = Data::Dumper->new([$_[0]],[$_[1]]);
  74         $d->Purity(1)->Indent(1)->Useqq(1)->Quotekeys(0)->Sortkeys(1)->Deparse($_[2]||0);
  75         $d->Dump;
  76 }}
  77
  78 my $_dumpstr;
  79 BEGIN {$_dumpstr = sub {
  80         my $d = Data::Dumper->new([$_[0]]);
  81         $d->Purity(1)->Indent(0)->Useqq(1)->Quotekeys($_[1]||0)->Sortkeys(1)->Terse(1);
  82         $d->Dump;
  83 }}
  84
  85 my $_dumpenv;
  86 BEGIN {$_dumpenv = sub {
  87         my ($k, $v) = @_;
  88         return 'delete $ENV{'.&$_dumpstr($k)."};\n" unless @$v;
  89         return '$ENV{'.&$_dumpstr($k).'} = '.&$_dumpstr($$v[0],1).";\n";
  90 }}
  91
  92 my $_scalarexists;
  93 BEGIN {$_scalarexists = sub {
  94         # *foo{SCALAR} returns a reference to an anonymous scalar if $foo
  95         # has not been used yet thereby creating the scalar and "using" it.
  96         # Later perls (5.9+) assign a special value that can be detected.
  97         B::svref_2object($_[0])->SV->isa("B::SV") # isa will be false if it's "special"
  98         # additionally ...SV->can("object_2svref") will be undef if it's "special"
  99 }}
 100
 101 sub Boilerplate {
 102         return 'umask(umask() & ~0770);'."\n";
 103 }
 104
 105 sub Scalars {
 106         my $ns = shift;
 107         my $hr = eval '\%'.$ns.'::';
 108         my @result = ();
 109         foreach (&$_sortkeys($hr)) {
 110                 my $gr = eval '\$'.$ns.'::{$_}';
 111                 push(@result, $_) if &$_scalarexists($gr) && !ref($$$gr);
 112         }
 113         return @result;
 114 }
 115
 116 sub Dump {
 117         my $ns = shift;
 118         my $hr = eval '\%'.$ns.'::';
 119         my $result = "";
 120         foreach (&$_sortkeys($hr)) {
 121                 my $gr = eval '\$'.$ns.'::{$_}';
 122                 if (&$_scalarexists($gr)) {
 123                         $result .= "our ".&$_dumpit($$$gr, $_, ref($$$gr) eq 'CODE');
 124                 }
 125                 if (defined(*$$gr{ARRAY})) {
 126                         $result .= "our ".&$_dumpit(\@$$gr, '*'.$_);
 127                 }
 128                 if (defined(*$$gr{HASH})) {
 129                         $result .= "our ".&$_dumpit(\%$$gr, '*'.$_);
 130                 }
 131                 #if (defined(*$$gr{CODE})) {
 132                 #       $result .= &$_dumpit(\&$$gr, '*'.$_, 1);
 133                 #}
 134         }
 135         return $result;
 136 }
 137
 138 sub RequireENV {
 139         my $inmod = shift;
 140         !ref($inmod) and $inmod = [ $inmod ];
 141         ref($inmod) eq 'ARRAY' or die "invalid argument to RequireENV - must be scalar or ARRAY ref";
 142         my @mod = ();
 143         do {
 144                 /^(\w+(?:::\w+)*)$/ or die "invalid module name: '$_'";
 145                 push(@mod, $1);
 146         } foreach @$inmod;
 147         do {
 148                 my $modname = $_;
 149                 my $modkey = $modname;
 150                 $modkey =~ s{::}{/}gs;
 151                 $modkey .= '.pm';
 152                 !exists($INC{$modkey}) or die "RequireENV('$modname') called but '$modname' already in \%INC!\n";
 153         } foreach @mod;
 154         my $envlog;
 155         my %env = %ENV;
 156         {
 157                 my $logobj = tie(%ENV, '_Girocco::Dumper::HashLog', \%env);
 158                 eval 'require '.$_.';1' or die $@ foreach @mod;
 159                 $envlog = $$logobj[1];
 160         }
 161         untie(%ENV);
 162         %ENV = %env;
 163         return $envlog;
 164 }
 165
 166 sub DumpENV {
 167         my $envlog = shift;
 168         my $result = "";
 169         $result .= &$_dumpenv($_, $envlog->{$_}) foreach &$_sortkeys($envlog);
 170         return $result;
 171 }
 172
 173 sub FreezeConfig {
 174         my ($usemod, $conf, $sub) = @_;
 175         defined($conf) && $conf ne "" or $conf = 'Girocco::Config';
 176         defined($usemod) && $usemod ne "" or $usemod = [$conf, 'Girocco::Validator'];
 177         my $env = RequireENV($usemod);
 178         # To avoid problems with taint mode, these four are always removed
 179         $env->{IFS} = [];
 180         $env->{CDPATH} = [];
 181         $env->{ENV} = [];
 182         $env->{BASH_ENV} = [];
 183         # Always make sure PATH gets set explicitly to something
 184         exists($env->{PATH}) && @{$env->{PATH}} or $env->{PATH} = [GetConfPath()];
 185         if (exists($env->{PATH}) && @{$env->{PATH}}) {
 186                 # special handling for $ENV{PATH}
 187                 my $pval = ${$env->{PATH}}[0];
 188                 eval '$'.$conf.'::path = $pval;1' or die $@;
 189         }
 190         &$sub($conf) if ref($sub) eq 'CODE';
 191         return "package $conf;\n" . Dump($conf) . DumpENV($env) .
 192                 Boilerplate() . "1;\n";
 193 }
 194
 195 sub GetConfPath {
 196         local ($ENV{IFS}, $ENV{CDPATH}, $ENV{ENV}, $ENV{BASH_ENV});
 197         local $ENV{PATH} = "/usr/bin:/bin";
 198         my $cs_path = qx(getconf PATH 2>/dev/null);
 199         defined($cs_path) or $cs_path = "";
 200         chomp $cs_path; $cs_path =~ s/^\s+//; $cs_path =~ s/\s+$//;
 201         $cs_path = join(":", grep(!m{/[.]}, grep(m{^/.},
 202                 split(/\s*:+\s*/, $cs_path))));
 203         $cs_path =~ m{^(/.+)$} and $cs_path = $1;
 204         $cs_path ne "" or $cs_path = $ENV{PATH};
 205         return $cs_path;
 206 }
 207
 208 1;