view release on metacpan or  search on metacpan

lib/Data/Show.pm  view on Meta::CPAN

}


# Useful regexes...
my $OWS;         BEGIN { $OWS         = qr{ (?: \s++ | \# [^\n]*+ )*+ }x;               }
my $IDENT;       BEGIN { $IDENT       = qr{ [^\W\d]\w* (?: :: [^\W\d]\w* )* | [_\W] }x; }
my $COLOUR_CHAR; BEGIN { $COLOUR_CHAR = qr{ (?: \e[^m]*m )*  [^\n]  (?: \e[^m]*m )* }x; }
my $VALID_ARG;   BEGIN { $VALID_ARG   = qr{ \A (?: to        | with      | fallback
                                                 | base      | warnings  | as
                                                 | style     | grid      | termwidth
                                                 | datastyle | filestyle | linestyle
                                                 | codestyle | showstyle | gridstyle
                                               ) \z }x; }

# Track lexically scoped output targets and styles...
my @OUTPUT_FH;
my @STYLE;

# Export the module's API, or that of a plugin (as requested)...
sub import {
    # Track load context...
    my ($package, $file, $line) = _get_context();

    # Remove the module name from the argument list...
    shift @_;

    # Handle the special case of a 'base' argument (by adding it as the caller's base class)...
    if (@_ > 0 && $_[0] eq 'base') {
        die "If 'base' is specified, it must be the only argument at $file line $line\n" if @_ > 2;
        no strict 'refs';
        push @{caller().'::ISA'}, _load_plugin( $_[1] // 'Data::Show::Plugin', $file, $line, 'warn' );
        return;
    }

    # Check for missing named args and improve the usual warning for that problem...
    die "No value specified for named argument '$_[-1]' at $file line $line\n"
        if @_ % 2 != 0;

    # Unpack args (including defaults from config file)....
    state $defaults_ref = _load_defaults($file, $line);
    my %opt = (%{$defaults_ref}, @_);

    # Punish invalid arguments...
    _validate_args(\%opt, "at $file line $line", "named argument");

    # Any 'to' arg must be a filehandle, filename, or scalar ref (and open it if necessary)...
    $opt{to} = _open_target( $opt{to} // $DEFAULT_TARGET, $file, $line, $opt{warnings} ne 'off' );

    # Unpack fallback arguments into an arrayref...
    $opt{fallback} = [ split m{ \s*,\s* }x, $opt{fallback} ];

    # Resolve style options according to terminal background (i.e. dark or light)
    for my $option (@opt{ grep /\A.+style\z/, keys %opt}) {
        $option = [split /\s*,\s*/, $option]->[$IS_LIGHT_BG ? -1 : 0];
    }

    # Install Data::Show::Plugin base class as well...
    $INC{'Data/Show/Plugin.pm'} = $INC{'Data/Show.pm'};

    # Track lexical options...
    $^H{'Data::Show/with'}       = _load_plugin( $opt{with}, $file, $line,
                                                 $opt{warnings} ne 'off', $opt{fallback} );
    $^H{'Data::Show/termwidth'}  = $opt{termwidth};
    $^H{'Data::Show/to'}         = @OUTPUT_FH;
    $^H{'Data::Show/style'}      = @STYLE;
    my $existing_as              = $^H{'Data::Show/as'} // '(?!)';
    $^H{'Data::Show/as'}         = "$existing_as|$opt{as}";
    push @OUTPUT_FH, $opt{to};
    push @STYLE,     { add_grid => $opt{grid},
                       mode     => $opt{style},
                       map { m/(.+)style/ ? ($1 => $opt{$_}) : () } keys %opt
                     };

    # Install the function...
    no strict 'refs';
    *{caller() . '::' . $opt{as}} = \&show;
}

# A "no Data::Show" turns show() into a no-op...
sub unimport {
    # Track disabling lexically...
    $^H{'Data::Show/noshow'} = 1;

    # Install the function...
    no strict 'refs';
    *{caller() . '::show'} = \&show;
}

sub _validate_args {
    my ($opt_ref, $where, $what) = @_;

    # Collect and report non-valid arguments...
    my @unknown_args = grep { !m{$VALID_ARG} } keys %{$opt_ref};
    die "Unknown $what" . (@unknown_args == 1 ? '' : 's') . " $where:\n",
        join q{}, map { "    $_\n" } @unknown_args
            if @unknown_args;

    # By the time we're validating, we shouldn't see a 'base' option...
    return if !exists $opt_ref->{base};
    die $what eq 'named argument' ? "If 'base' is specified, it must be the only argument $where\n"
                                  : "Can't specify 'base' as a $what $where\n"
}

# Ensure output filehandles are valid (or fall back to the default)...
sub _open_target {
    my ($target, $file, $line, $warnings) = @_;

    # Track already opened targets, and reuse them...
    state %already_open;
    return $already_open{$target} if $already_open{$target};

    # Handle stringy filenames and in-memory targets...
    my $to_type = ref($target);
    if (!$to_type && ref(\$target) ne 'GLOB' || $to_type eq 'SCALAR') {
        if (open my $fh, '>', $target) {
            return ($already_open{$target} = $fh);
        }
        else {
            warn "Could not open named 'to' argument for output at $file line $line\n"
                if $warnings;
            return ($already_open{$target} = $DEFAULT_TARGET);
        }
    }

    # Handle filehandle-y targets...
    elsif (_is_writeable($target)) {
        return ($already_open{$target} = $target);