dtRdr::Hack - self-documenting adaptive finger-wagging global vars

  package WayOver::OnThe::Left;
  use dtRdr::Hack;  dtRdr::Hack->set_variableB(45);

  package Bottom::Right::Corner;
  use dtRdr::Hack;
  my $variableB = dtRdr::Hack->get_variableB;

  my %declared = (
    some_scalar => '',                       # scalar
    some_array  => [],                       # array
    some_hash   => {},                       # hash
    some_univ   => bless({}, 'UNIVERSAL'),   # any object
    some_obj    => bless({}, 'dtRdr::Book'), # class or subclass
    some_sub    => sub {_die 'ex_sub'},      # declare subs like this
    some_undef  => undef,                    # run-time typing
  );

  my %deprecated = (
    some_other_scalar => '',
    some_other_array  => [],
    some_other_hash   => {},
    some_other_sub    => sub {_die 'ex_sub'},
  );

package dtRdr::Hack;
$VERSION = eval{require version}?version::qv($_):$_ for(0.10.1);

use warnings;
use strict;


use Carp qw(
  croak
  carp
  cluck
  confess
  );

my $widget_img = <<'WIDGET_IMG';
<img src="data:image/png;base64,
iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABmJLR0QAAAAAAAD5Q7t/AAAACXBI
WXMAAAsRAAALEQF/ZF+RAAACC0lEQVQ4y3VTz2sTQRT+kmzBihGpvXlwQWS7KQpe9CLMpL0pWPwV
IR5qEwXRc4OH0N2tgZK2/0IFb0KtNj30YAk7iyC15ya7e1AaxEthU0OhhWTJeOmE7e72wcC8eW++
7733zYBzDs45OtUJ0yukeNdmRJwFV9dmxCukeDhnkCCCneqEGb58tG5oZ8UTnHMAQLsocUkhbEgh
DCE73pjXxT49W6dDY8QSvgQAPccicclxFrwMINpCuMeuzcjW9NXYGOccySB7sMTi82e8traqbTb2
6afebaRn6xQAfNeipyoIMh+tG1qcAkEVIhVIgaH1XIse1+Y14f+t3jM3p6/ztr1NIswnllrY+v1R
Ugjrey3Zdy3quxbtuRZNXpb3/vBL+Lr7j1472JHTbUfuey35QvHDTBBgIONyRTPbzjZ9d9Nngk30
fbg0OahyZMVPBAGSALBYMUzbduidhy/1i6V69puvYq8/gsOlSRZ+A5EWbt0Y1358t14oaoYVX7+Z
WawY5s4+5HPKXaYc/JT7XksWzKlRuRUBOC8lmKJmWKmsZZ1mg2x8+awraoa9LS9kf/VHYdtNeiXZ
gaQQFgeA6nt98LYL+Rwv5HPcbuwS4b/KPxnIHCdvslTWsmIOAKCoGTaWGbdqa6saANx/lNOHH8zp
ABCU+NQQnWaDuHaTAoAAFDb1+KkxPDVnnPU3/gMTNJSCnLOiXgAAAABJRU5ErkJggg==
">
WIDGET_IMG
########################################################################
# Declare your variables.  See import() for examples.
########################################################################
# DECLARED variables
my %declared = (
  widget_img => $widget_img, # to check if widgets work
  );

########################################################################
# DEPRECATED variables -- warnings, but not errors
my %deprecated = (
  inline_image_sub  => sub { # base64 encoding
    my ($imagepath,$ext,$book)=@_;
    use MIME::Base64;
    my $image = $book->get_member_string($imagepath) or
      warn qq( couldn't get image $!);
    my $enc_image = MIME::Base64::encode($image);
    return qq(<img src="data:image/$ext;base64,$enc_image" />);
  },
  current_book  => bless({}, 'dtRdr::Book'), # assumes only one book
  );
########################################################################

# anything else throws errors if strict is on
use constant {
  WARNINGS => 1,
  STRICT   => 1,
  TRACE    => 0,
  };

our $AUTOLOAD;
my %defs;  # type cache
my %store; # actual storage

sub _die ($);

# import is only here to enable testing
# TODO? add trace=> 1 option to turn on tracing
sub import {
  my ($package, %opts) = @_;

  if($opts{testing}) { # assign testing vars
    # don't use ex_ or exd_ prefixes -- those are mine
    my %tdeclared = (
      ex_scalar => '', # scalar
      ex_array  => [], # array
      ex_hash   => {}, # hash
      ex_obj    => bless({}, 'dtRdr::Book'), # stricter than hash
      ex_sub    => sub {_die 'ex_sub'}, # declare subs like this
      ex_undef  => undef, # anything you want
      ex_univ  => bless({}, 'UNIVERSAL'), # anything object you want
    );
    my %tdeprecated = (
      exd_scalar => '', # scalar
      exd_array  => [], # array
      exd_hash   => {}, # hash
      exd_sub    => sub {_die 'ex_sub'}, # declare subs like this
    );
    my @pairs = (
      [\%declared, \%tdeclared],
      [\%deprecated, \%tdeprecated],
    );
    foreach my $pair (@pairs) {
      foreach my $key (keys(%{$pair->[1]})) {
        exists($pair->[0]{$key}) and die "I said don't use names like $key";
        $pair->[0]{$key} = $pair->[1]{$key};
      }
    }
  }
} # end subroutine import definition
########################################################################

sub AUTOLOAD {
  my ($self, @args) = @_;
  my ( $var_name, $action ) = _parse_autoload_method($AUTOLOAD);

  # one-time
  %defs or _build_defs();

  # THE PLAN
  # is var_name declared?
  #   yes => (strict? rtime check_type : whatever)
  #   no =>  (strict? ctime croak      : (warnings? ctime warn : ok))
  # is var_name deprecated? => (warnings? rtime warn : ok)

  # we have something like compile time
  #   ctime:  first call -- only time we're in AUTOLOAD
  # and something like runtime
  #   rtime:  every call

  # NOTE we want to install the closure in our package so we only hit
  # the AUTOLOAD() once -- this isn't safe to be inherited because it
  # smashes your sub on $self->SUPER::foo() calls

  unless(exists($defs{$var_name})) {
    STRICT and croak("'$var_name' undeclared in ", __PACKAGE__);
    WARNINGS and carp("WARNING $var_name undeclared in ", __PACKAGE__);
  }

  # grab pre-determined type
  my $type = $defs{$var_name};

  # $check_type is an rtime croak if STRICT
  my $check_type = STRICT ? sub {_check_type($var_name, $type, @_)} : sub {};

  # $run_warn is an rtime warning
  my $run_warn = sub {};
  if(WARNINGS) {
    if(exists($deprecated{$var_name})) {
      $run_warn = sub {_warn_deprecated($action . "_" . $var_name)};
    }
    # TODO? check for other things to warn about?
  }

  # cluck("action: '$action' on '$var_name'");

  my $install_sub;
  if($action eq 'set') {
    # warn "defining set_$var_name";
    $install_sub = sub {
      my $self = shift;
      @_ or croak("'set_$var_name()' requires variable");
      my $val = shift(@_);
      $check_type->($val);
      $run_warn->();
      return($store{$var_name} = $val);
    };
  }
  elsif($action eq 'get') {
    $install_sub = sub {
      my $self = shift;
      $run_warn->();
      return($store{$var_name});
    };
  }
  else {
    die "action '$action' not implemented";
  }

  $install_sub or die "problem";
  {
    no strict 'refs';
    *{$AUTOLOAD} = $install_sub;
  }
  goto &$AUTOLOAD;
} # end subroutine AUTOLOAD definition
########################################################################

sub _check_type {
  my ($var_name, $type, $var) = @_;
  croak("trouble") unless(scalar(@_) == 3);

  # warn "check '$var_name', '$type', '$var'";

  # TODO? I guess I could look that up myself...
  return(1) unless(defined($type));

  # TODO and I could implement strong dynamic typing for undef()
  # declarations here as well.

  return(1) if(_type($var) eq $type);

  # XXX should we allow set hash to any object?
  # this allows that and any object -> bless({}, 'UNIVERSAL')
  return(1) if eval {$var->isa($type)};

  croak("'$var_name' type declared as '$type' not '", _type($var), "'");
} # end subroutine _check_type definition
########################################################################

sub _warn_deprecated {
  my ($var_name) = @_;

  my $color = sub {
    my $def = sub {""}; (-t STDERR) or return($def);
    eval { require Term::ANSIScreen }; $@ and return($def);
    return(\&Term::ANSIScreen::color);
  }->();

  my ($cp, $cl) = (caller(2))[0,2];
  local $SIG{__WARN__}; # wag finger no matter what
  warn(((-t STDOUT) ? "" : "\n"),
    $color->('bold white on red'), "DEPRECATED:", $color->('reset'),
    "  dtRdr::Hack->",
    $color->('bold red on black') . $var_name, $color->('reset') ,
    " at '$cp' line $cl\n");
} # end subroutine _warn_deprecated definition
########################################################################

sub _type {
  my ($var) = @_;
  defined($var) or return(); # undefined
  my $ref = ref($var);
  $ref or return('');        # scalar -- XXX?
  # should package/hash/array/code/glob refs be more rigorously checked?
  return($ref);
} # end subroutine _type definition
########################################################################

sub _build_defs {
  %defs and croak "do not call this twice";

  foreach my $hash (\%declared, \%deprecated) {
    foreach my $k (keys(%$hash)) {
      $defs{$k} = _type($hash->{$k});
      exists($store{$k}) and die "$k declared twice";
      $store{$k} = $hash->{$k};
    }
  }

} # end subroutine _build_defs definition
########################################################################

# adopted from Best Practical's Jifty::DBI::Record
sub _parse_autoload_method {
  my $method = shift;

  my ( $var_name, $action );

  if($method !~ m/^.*::(?:set_|get_)/o) {
    croak("method must start with get_|set_ ('$method')");
  }
  elsif ( $method =~ m/^.*::([gs]et)_(\w+)$/o ) {
    $action = $1;
    $var_name = $2;
  }
  else {
    croak("missing variable in '$method'");
  }
  return ( $var_name, $action );
} # end subroutine _parse_autoload_method definition
########################################################################

sub _die ($) {
  my $var = shift;
  confess("undeclared sub $var");
} # end subroutine _die definition
########################################################################

# vi:ts=2:sw=2:et:sta
1;