view release on metacpan or  search on metacpan

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

A Fernet key can be provided as the second argument, and this can be a
Base64-encoded string or a C<DBIx::Squirrel::Crypt::Fernet> instance. If no
second argument is defined, the function will fall back to using the
C<FERNET_KEY> 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<get_file_contents>

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


=head3 C<utf8decode>

    $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 <cpanic@cpan.org>

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