From bc9113ede106f74c8618cef4fc58772d7e5db1b7 Mon Sep 17 00:00:00 2001 From: "Kyle J. McKay" Date: Thu, 29 Oct 2020 05:32:22 -0700 Subject: [PATCH] Girocco/Dumper.pm: new module to assist with installation config The Girocco/Config.pm module supplies Girocco's configuration for the installation. It is "use"d by virtually every perl module that's part of Girocco. It's sole purpose is to set configuration variables. However, it also contains various validation code and so forth that runs during installation to validate various settings and so on. There's no reason to run the validation code after the settings have been validated at installation time and then installed. Provide utility functions in Girocco::Dumper that can "freeze" a configuration into a new module file that does nothing except set configuration values -- both *Girocco::Config:: AND $ENV{} AND the umask. The installation process already does something similar for use by shell scripts when it creates the 'shlib_vars.sh' file during installation. Provide a utility function for 'shlib_vars.sh' creation as well to avoid including non-scalar variables and scalars that contain a reference in the generated 'shlib_vars.sh' because they just end up as useless garbage when they are stringified. Signed-off-by: Kyle J. McKay --- Girocco/Dumper.pm | 178 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 178 insertions(+) create mode 100644 Girocco/Dumper.pm diff --git a/Girocco/Dumper.pm b/Girocco/Dumper.pm new file mode 100644 index 0000000..5887355 --- /dev/null +++ b/Girocco/Dumper.pm @@ -0,0 +1,178 @@ +# Girocco::Dumper.pm -- Installation Utility Dumper Functions +# Copyright (C) 2020 Kyle J. McKay. All rights reserved. + +# This program is free software; you can redistribute it and/or +# modify it under the terms of the GNU General Public License +# as published by the Free Software Foundation; either version 2 +# of the License, or (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + +{package _Girocco::Dumper::HashLog; + +use strict; +use warnings; + +use Tie::Hash (); +use base qw(Tie::ExtraHash); + +sub TIEHASH { + my $class = shift; + my $hr = $_[0]; + ref($hr) eq 'HASH' or $hr = {}; + my $self = bless([$hr, {}], $class); + return $self; +} + +sub STORE { + my $self = shift; + ${$$self[1]}{$_[0]} = [$_[1]]; + $self->SUPER::STORE(@_); +} + +sub DELETE { + my $self = shift; + ${$$self[1]}{$_[0]} = []; + $self->SUPER::DELETE(@_); +} + +} + +package Girocco::Dumper; + +use strict; +use warnings; + +use base qw(Exporter); +our ($VERSION, @EXPORT, @EXPORT_OK); + +BEGIN { + @EXPORT = qw(); + @EXPORT_OK = qw(RequireENV Dump DumpENV Boilerplate Scalars FreezeConfig); + *VERSION = \'1.0'; +} + +use B (); +use Data::Dumper (); + +my $_sortkeys; +BEGIN {$_sortkeys = sub { + package _Girocco::Dumper; + sort({uc($a) cmp uc($b) || $a cmp $b} keys(%{$_[0]})); +}} + +my $_dumpit; +BEGIN {$_dumpit = sub { + my $d = Data::Dumper->new([$_[0]],[$_[1]]); + $d->Purity(1)->Indent(1)->Useqq(1)->Quotekeys(0)->Sortkeys(1)->Deparse($_[2]||0); + $d->Dump; +}} + +my $_dumpstr; +BEGIN {$_dumpstr = sub { + my $d = Data::Dumper->new([$_[0]]); + $d->Purity(1)->Indent(0)->Useqq(1)->Quotekeys($_[1]||0)->Sortkeys(1)->Terse(1); + $d->Dump; +}} + +my $_dumpenv; +BEGIN {$_dumpenv = sub { + my ($k, $v) = @_; + return 'delete $ENV{'.&$_dumpstr($k)."};\n" unless @$v; + return '$ENV{'.&$_dumpstr($k).'} = '.&$_dumpstr($$v[0],1).";\n"; +}} + +my $_scalarexists; +BEGIN {$_scalarexists = sub { + # *foo{SCALAR} returns a reference to an anonymous scalar if $foo + # has not been used yet thereby creating the scalar and "using" it. + # Later perls (5.9+) assign a special value that can be detected. + B::svref_2object($_[0])->SV->isa("B::SV") # isa will be false if it's "special" + # additionally ...SV->can("object_2svref") will be undef if it's "special" +}} + +sub Boilerplate { + return 'umask(umask() & ~0770);'."\n"; +} + +sub Scalars { + my $ns = shift; + my $hr = eval '\%'.$ns.'::'; + my @result = (); + foreach (&$_sortkeys($hr)) { + my $gr = eval '\$'.$ns.'::{$_}'; + push(@result, $_) if &$_scalarexists($gr) && !ref($$$gr); + } + return @result; +} + +sub Dump { + my $ns = shift; + my $hr = eval '\%'.$ns.'::'; + my $result = ""; + foreach (&$_sortkeys($hr)) { + my $gr = eval '\$'.$ns.'::{$_}'; + if (&$_scalarexists($gr)) { + $result .= "our ".&$_dumpit($$$gr, $_, ref($$$gr) eq 'CODE'); + } + if (defined(*$$gr{ARRAY})) { + $result .= "our ".&$_dumpit(\@$$gr, '*'.$_); + } + if (defined(*$$gr{HASH})) { + $result .= "our ".&$_dumpit(\%$$gr, '*'.$_); + } + #if (defined(*$$gr{CODE})) { + # $result .= &$_dumpit(\&$$gr, '*'.$_, 1); + #} + } + return $result; +} + +sub RequireENV { + my $mod = shift; + my $modkey = $mod; + $modkey =~ s{::}{/}gs; + $modkey .= '.pm'; + !exists($INC{$modkey}) or die "RequireENV('$mod') called but '$mod' already in \%INC!\n"; + my $envlog; + my %env = %ENV; + { + my $logobj = tie(%ENV, '_Girocco::Dumper::HashLog', \%env); + eval 'require '.$mod.';1' or die $@; + $envlog = $$logobj[1]; + } + untie(%ENV); + %ENV = %env; + return $envlog; +} + +sub DumpENV { + my $envlog = shift; + my $result = ""; + $result .= &$_dumpenv($_, $envlog->{$_}) foreach &$_sortkeys($envlog); + return $result; +} + +sub FreezeConfig { + my ($usemod, $conf, $sub) = @_; + defined($conf) && $conf ne "" or $conf = 'Girocco::Config'; + defined($usemod) && $usemod ne "" or $usemod = $conf; + my $env = RequireENV($usemod); + if (exists($env->{PATH}) && @{$env->{PATH}}) { + # special handling for $ENV{PATH} + my $pval = ${$env->{PATH}}[0]; + eval '$'.$conf.'::path = $pval;1' or die $@; + } + &$sub($conf) if ref($sub) eq 'CODE'; + return "package $conf;\n" . Dump($conf) . DumpENV($env) . + Boilerplate() . "1;\n"; +} + +1; -- 2.11.4.GIT