view release on metacpan or  search on metacpan

lib/DBIx/Squirrel/util.pm  view on Meta::CPAN

use strict;
use warnings;
use 5.010_001;

package    # hide from PAUSE
    DBIx::Squirrel::util;

=pod

=encoding UTF-8

=head1 NAME

DBIx::Squirrel::util - Utilities

=head1 DESCRIPTION

A collection of helper functions used by other DBIx::Squirrel packages.

=cut

our @ISA = qw(Exporter);
our @EXPORT;
our %EXPORT_TAGS = ( all => [
    our @EXPORT_OK = qw(
        callbacks
        callbacks_args
        carpf
        cluckf
        confessf
        decrypt
        get_file_contents
        global_destruct_phase
        has_callbacks
        slurp
        uncompress
        unmarshal
        utf8decode
    )
] );

use Carp                          ();
use Compress::Bzip2               ();
use Devel::GlobalDestruction      ();
use Dotenv                        ();
use Encode                        ();
use Exporter                      ();
use JSON::Syck                    ();
use DBIx::Squirrel::Crypt::Fernet ();

if ( -e '.env' ) {
    Dotenv->load();
}

=head2 EXPORTS

Nothing is exported by default.

=cut


=head3 C<callbacks>

    @callbacks = callbacks(\@array);
    $count = callbacks(\@array);

When called in list-context, this function removes and returns any trailing
CODEREFs found in the array referenced by the only argument. Be mindful that
this operation potentially alters the referenced array.

When called in scalar-context then the function returns a non-zero count of
the number of trailing CODEREFs found, or C<undef> if there were none. When
called in scalar-context then the array is not altered, even if there were
trailing CODEREFs.

=cut

sub callbacks {
    return unless 1 == @_ && UNIVERSAL::isa( $_[0], 'ARRAY' );
    goto &_callbacks;
}

sub _callbacks {
    return unless my @splice = _has_callbacks( $_[0] );
    return $splice[1] unless wantarray;
    return splice @{ $_[0] }, $splice[0], $splice[1];
}


=head3 C<callbacks_args>

    (\@callbacks, @arguments) = callbacks_args(@argments);

When using C<DBIx::Squirrel>, some calls allow the caller to reshape results
before they are returned, using transformation pipelines. A transformation
pipeline is one or more contiguous code-references presented at the end of
a call's argument list. 

Th C<callbacks_args> function inspects an array of arguments, moving any
trailing code-references from the source array into a separate array — the
transformation pipeline. It returns a reference to that array, followed by
any remaining arguments, to the caller.

    (\@callbacks, @arguments) = &callbacks_args;

The terse C<&>-sigil calling style causes C<callbacks_args> to use the
calling function's C<@_> array.

=cut

sub callbacks_args {
    return [], @_ unless my @callbacks = callbacks( \@_ );
    return \@callbacks, @_;
}


=head3 C<carpf>

Emits a warning without a stack-trace.

    carpf();

The warning will be set to C<$@> if it contains something useful. Otherwise 
an "Unhelpful warning" will be emitted.

    carpf($message);
    carpf(\@message);

The warning will be set to C<$message>, or the concatenated C<@message> array,
or C<$@>, if there is no viable message. If there is still no viable message
then an "Unhelpful warning" is emitted.

During concatenation, the elements of the C<@message> array are separated
by a single space. The intention is to allow for long warning messages to be
split apart in a tidier manner.

    carpf($format, @arguments);
    carpf(\@format, @arguments);

The warning is composed using a C<sprintf> format-string (C<$format>), together
with any remaining arguments. Alternatively, the format-string may be produced
by concatenating the C<@format> array whose elements are separated by a single
space.

=cut

sub carpf {
    @_ = do {
        if (@_) {
            my $format = do {
                if ( UNIVERSAL::isa( $_[0], 'ARRAY' ) ) {
                    join ' ', @{ +shift };
                }
                else {
                    shift;
                }
            };
            if (@_) {
                sprintf $format, @_;
            }
            else {
                $format or $@ or 'Unhelpful warning';
            }
        }
        else {
            $@ or 'Unhelpful warning';
        }
    };
    goto &Carp::carp;
}


=head3 C<cluckf>

lib/DBIx/Squirrel/util.pm  view on Meta::CPAN

=item *

If ".encrypted" forms part of the file's name or the C<decrypt> option is
true, then the file contents will be decrypted after they have been read
using the Fernet key provided in the C<fernet> option or the C<FERNET_KEY>
environment variable.

=item *

If ".bz2" forms part of the file's name or the C<uncompress> option is
true, then the file contents will be uncompressed after they have been read
and possibly decrypted.

=item *

If ".json" forms part of the file's name or the C<unmarshal> option is
true, then the file contents will be unmarshalled after they have been read,
possibly decrypted, and possibly uncompressed.

=item *

If the C<utf8decode> option is true, then the file contents will be decoded
as a UTF-8 string.

=back

=cut

sub get_file_contents {
    my $filename = shift;
    my $options  = { utf8decode => !!1, %{ shift || {} } };
    my $contents = slurp($filename);
    $contents = decrypt( $contents, $options->{fernet} )
        if $filename =~ /\.encrypted\b/ || $options->{decrypt};
    $contents = uncompress($contents)
        if $filename =~ /\.bz2\b/ || $options->{uncompress};
    return unmarshal($contents)
        if $filename =~ /\.json\b/ || $options->{unmarshal};
    return utf8decode($contents)
        if $options->{utf8decode};
    return $_ = $contents;
}


=head3 C<global_destruct_phase>

    $bool = global_destruct_phase();

Detects whether the Perl program is in the Global Destruct Phase. Knowing
this can make C<DESTROY> methods safer. Perl versions older than 5.14
don't support the ${^GLOBAL_PHASE} variable, so provide a shim that
works regardless of Perl version.

=cut

sub global_destruct_phase {
    return Devel::GlobalDestruction::in_global_destruction();
}


=head3 C<has_callbacks>

    ($position, $count) = has_callbacks(\@array);

When called in list-context, this function returns the starting position
and a count of the trailing CODEREFs found in the array referenced in the
only argument. If no trailing CODEREFs were found then the function will
return an empty list.

When called in scalar-context then a truthy value indicating the presence
of callbacks will be returned.

=cut

sub has_callbacks {
    return unless 1 == @_ && UNIVERSAL::isa( $_[0], 'ARRAY' );
    goto &_has_callbacks;
}

sub _has_callbacks {
    my $n = my $s = scalar @{ $_[0] };
    $n-- while $n && UNIVERSAL::isa( $_[0][ $n - 1 ], 'CODE' );
    return                                  if $n == $s;
    return $n ? ( $n, $s - $n ) : ( 0, $s ) if wantarray;
    return $n;
}


=head3 C<slurp>

    $buffer = slurp();
    $buffer = slurp($filename);

Reads the entirety of the specified file in raw mode, returning the contents.

If C<$filename> is omitted then C<$_> will be used.

=cut

sub slurp {
    my $filename = @_ ? shift : $_;
    open my $fh, '<:raw', $filename
        or confessf "$! - $filename";
    read $fh, my $buffer, -s $filename;
    close $fh;
    return $_ = $buffer;
}


=head3 C<uncompress>

    $buffer = uncompress();
    $buffer = uncompress($buffer);

Uncompresses a Bzip2-compressed buffer, returning the uncompressed data.

If C<$buffer> is omitted then C<$_> will be used.

=cut

sub uncompress {
    my $buffer = @_ ? shift : $_;
    return $_ = Compress::Bzip2::memBunzip($buffer);
}


=head3 C<unmarshal>

    $data = unmarshal($json);
    $data = unmarshal($json, $decode);

Unmarshals a JSON-encoded buffer into the data-structure it represents. By
default, UTF-8 binaries are properly decoded, and this behaviour can be
inhibited by setting C<$decode> to false.

=cut

sub unmarshal {
    my $json   = shift;
    my $decode = @_ ? !!shift : !!1;