Girocco/Dumper.pm

   1 # Girocco::Dumper.pm -- Installation Utility Dumper Functions
   2 # Copyright (C) 2020 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);
  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 $mod = shift;
 140         my $modkey = $mod;
 141         $modkey =~ s{::}{/}gs;
 142         $modkey .= '.pm';
 143         !exists($INC{$modkey}) or die "RequireENV('$mod') called but '$mod' already in \%INC!\n";
 144         my $envlog;
 145         my %env = %ENV;
 146         {
 147                 my $logobj = tie(%ENV, '_Girocco::Dumper::HashLog', \%env);
 148                 eval 'require '.$mod.';1' or die $@;
 149                 $envlog = $$logobj[1];
 150         }
 151         untie(%ENV);
 152         %ENV = %env;
 153         return $envlog;
 154 }
 155
 156 sub DumpENV {
 157         my $envlog = shift;
 158         my $result = "";
 159         $result .= &$_dumpenv($_, $envlog->{$_}) foreach &$_sortkeys($envlog);
 160         return $result;
 161 }
 162
 163 sub FreezeConfig {
 164         my ($usemod, $conf, $sub) = @_;
 165         defined($conf) && $conf ne "" or $conf = 'Girocco::Config';
 166         defined($usemod) && $usemod ne "" or $usemod = $conf;
 167         my $env = RequireENV($usemod);
 168         if (exists($env->{PATH}) && @{$env->{PATH}}) {
 169                 # special handling for $ENV{PATH}
 170                 my $pval = ${$env->{PATH}}[0];
 171                 eval '$'.$conf.'::path = $pval;1' or die $@;
 172         }
 173         &$sub($conf) if ref($sub) eq 'CODE';
 174         return "package $conf;\n" . Dump($conf) . DumpENV($env) .
 175                 Boilerplate() . "1;\n";
 176 }
 177
 178 1;