File Coverage

blib/lib/DBIx/Squirrel/util.pm

Criterion	Covered	Total	%
statement	77	115	66.9
branch	35	76	46.0
condition	12	27	44.4
subroutine	19	26	73.0
pod	13	13	100.0
total	156	257	60.7

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(\@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 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, @arguments) = callbacks_args(@argments);

When using C, 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 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 to use the
calling function's C<@_> array.

=cut

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


=head3 C

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 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

Emits a warning with a stack-trace.

    cluckf();

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

    cluckf($message);
    cluckf(\@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.

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

The warning is composed using a C 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 cluckf {
    @_ = 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::cluck;
}


=head3 C

Throws and exception with a stack-trace.

    confessf();

The error will be set to C<$@> if it contains something useful (effectivly
re-throwing the previous exception). Otherwise it will an "Unknown error"
exception is thrown.

    confessf($message);
    confessf(\@message);

The error 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 "Unknown error" is thrown.

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

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

The error message is composed using a C 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 confessf {
    @_ = do {
        if (@_) {
            my $format = do {
                if ( UNIVERSAL::isa( $_[0], 'ARRAY' ) ) {
                    join ' ', @{ +shift };
                }
                else {
                    shift;
                }
            };
            if (@_) {
                sprintf $format, @_;
            }
            else {
                $format or $@ or 'Unknown error';

            }
        }
        else {
            $@ or 'Unknown error';
        }
    };
    goto &Carp::confess;
}


=head3 C

    $buffer = decrypt($fernet_key);
    $buffer = decrypt($buffer, $fernet_key);

Decrypts a Fernet-encrypted buffer, returning the decrypted data.

A Fernet key can be provided as the second argument, and this can be a
Base64-encoded string or a C instance. If no
second argument is defined, the function will fall back to using the
C environment variable, and if that isn't defined then an
exception will be thrown.

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

=cut

sub decrypt {
    my $fernet = pop;
    my $buffer = @_ ? shift : $_;
    unless ( defined $fernet ) {
        unless ( defined $ENV{FERNET_KEY} ) {
            confessf [
                "Neither a Fernet key nor a Fernet object have been",
                "defined. Decryption is impossible",
            ];
        }
        $fernet = $ENV{FERNET_KEY};
    }
    $fernet = DBIx::Squirrel::Crypt::Fernet->new($fernet)
        unless UNIVERSAL::isa( $fernet, 'DBIx::Squirrel::Crypt::Fernet' );
    return $_ = $fernet->decrypt($buffer);
}


=head3 C

    $contents = get_file_contents($filename[, \%options]);

Return the entire contents of a file to the caller.

The file is read in raw (binary) mode. What happens to the contents after
reading depends on the file's name and/or the contents of C<%options>:

=over

=item *

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

=item *

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

=item *

If the C 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

    $bool = global_destruct_phase();

Detects whether the Perl program is in the Global Destruct Phase. Knowing
this can make C 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

    ($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

    $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

    $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

    $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;
    local $JSON::Syck::ImplicitUnicode = $decode;
    return $_ = JSON::Syck::Load( $decode ? utf8decode($json) : $json );
}


=head3 C

    $string = utf8decode();
    $string = utf8decode($buffer);

Decode a byte buffer, returning a UTF-8 string.

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

=cut

sub utf8decode {
    my $buffer = @_ ? shift : $_;
    return $_ = Encode::decode_utf8( $buffer, @_ );
}

=head1 AUTHORS

Iain Campbell

=head1 COPYRIGHT AND LICENSE

The DBIx::Squirrel module is Copyright (c) 2020-2025 Iain Campbell.
All rights reserved.

You may distribute under the terms of either the GNU General Public
License or the Artistic License, as specified in the Perl 5.10.0 README file.

=head1 SUPPORT / WARRANTY

DBIx::Squirrel is free Open Source software. IT COMES WITHOUT WARRANTY OF ANY KIND.

=cut

1;