File Coverage

blib/lib/Yancy/Util.pm

Criterion	Covered	Total	%
statement	165	179	92.1
branch	82	94	87.2
condition	30	38	78.9
subroutine	31	33	93.9
pod	11	11	100.0
total	319	355	89.8

package Yancy::Util;
our $VERSION = '1.086';
# ABSTRACT: Utilities for Yancy

#pod =head1 SYNOPSIS
#pod
#pod     use Yancy::Util qw( load_backend );
#pod     my $be = load_backend( 'memory://localhost', $schema );
#pod
#pod     use Yancy::Util qw( curry );
#pod     my $helper = curry( \&_helper_sub, @args );
#pod
#pod     use Yancy::Util qw( currym );
#pod     my $sub = currym( $object, 'method_name', @args );
#pod
#pod     use Yancy::Util qw( match );
#pod     if ( match( $where, $item ) ) {
#pod         say 'Matched!';
#pod     }
#pod
#pod     use Yancy::Util qw( fill_brackets );
#pod     my $value = fill_brackets( $template, $item );
#pod
#pod =head1 DESCRIPTION
#pod
#pod This module contains utility functions for Yancy.
#pod
#pod =head1 SEE ALSO
#pod
#pod L
#pod
#pod =cut

use Mojo::Base '-strict';
use Exporter 'import';
use List::Util qw( all any none first );
use Mojo::Loader qw( load_class );
use Scalar::Util qw( blessed );
use Mojo::JSON::Pointer;
use Mojo::JSON qw( to_json );
use Mojo::Util qw( xml_escape );
use Carp qw( carp );
use JSON::Validator;

our @EXPORT_OK = qw( load_backend curry currym copy_inline_refs match derp fill_brackets
    is_type order_by is_format json_validator );

#pod =sub load_backend
#pod
#pod     my $backend = load_backend( $backend_url, $schema );
#pod     my $backend = load_backend( { $backend_name => $arg }, $schema );
#pod     my $backend = load_backend( $db_object, $schema );
#pod
#pod Get a Yancy backend from the given backend URL, or from a hash reference
#pod with a backend name and optional argument. The C<$schema> hash is
#pod the configured JSON schema for this backend.
#pod
#pod A backend URL should begin with a name followed by a colon. The first
#pod letter of the name will be capitalized, and used to build a class name
#pod in the C namespace.
#pod
#pod The C<$backend_name> should be the name of a module in the
#pod C namespace. The C<$arg> is handled by the backend
#pod module. Read your backend module's documentation for details.
#pod
#pod The C<$db_object> can be one of: L, L,
#pod L, or a subclass of L. The
#pod appropriate backend object will be created.
#pod
#pod See L for information about
#pod backend URLs and L for more information about backend
#pod objects.
#pod
#pod =cut

# This allows users to pass in the database object directly
our %BACKEND_CLASSES = (
    'Mojo::Pg' => 'pg',
    'Mojo::mysql' => 'mysql',
    'Mojo::SQLite' => 'sqlite',
    'DBIx::Class::Schema' => 'dbic',
);

# Aliases allow the user to specify the same string as they pass to
# their database object
our %TYPE_ALIAS = (
    postgresql => 'pg',
);

sub load_backend {
    my ( $config, $schema ) = @_;
    my ( $type, $arg );
    if ( !ref $config ) {
        ( $type ) = $config =~ m{^([^:]+)};
        $type = $TYPE_ALIAS{ $type } // $type;
        $arg = $config;
    }
    elsif ( blessed $config ) {
        for my $class ( keys %BACKEND_CLASSES ) {
            if ( $config->isa( $class ) ) {
                ( $type, $arg ) = ( $BACKEND_CLASSES{ $class }, $config );
                last;
            }
        }
    }
    else {
        ( $type, $arg ) = %{ $config };
    }
    my $class = 'Yancy::Backend::' . ucfirst $type;
    if ( my $e = load_class( $class ) ) {
        die ref $e ? "Could not load class $class: $e" : "Could not find class $class";
    }
    return $class->new( $arg, $schema );
}

#pod =sub curry
#pod
#pod     my $curried_sub = curry( $sub, @args );
#pod
#pod Return a new subref that, when called, will call the passed-in subref with
#pod the passed-in C<@args> first.
#pod
#pod For example:
#pod
#pod     my $add = sub {
#pod         my ( $lop, $rop ) = @_;
#pod         return $lop + $rop;
#pod     };
#pod     my $add_four = curry( $add, 4 );
#pod     say $add_four->( 1 ); # 5
#pod     say $add_four->( 2 ); # 6
#pod     say $add_four->( 3 ); # 7
#pod
#pod This is more-accurately called L
#pod application|https://en.wikipedia.org/wiki/Partial_application>, but
#pod C is shorter.
#pod
#pod =cut

sub curry {
    my ( $sub, @args ) = @_;
    return sub { $sub->( @args, @_ ) };
}

#pod =sub currym
#pod
#pod     my $curried_sub = currym( $obj, $method, @args );
#pod
#pod Return a subref that, when called, will call given C<$method> on the
#pod given C<$obj> with any passed-in C<@args> first.
#pod
#pod See L for an example.
#pod
#pod =cut

sub currym {
    my ( $obj, $meth, @args ) = @_;
    my $sub = $obj->can( $meth )
        || die sprintf q{Can't curry method "%s" on object of type "%s": Method is not implemented},
            $meth, blessed( $obj );
    return curry( $sub, $obj, @args );
}

#pod =sub copy_inline_refs
#pod
#pod     my $subschema = copy_inline_refs( $schema, '/user' );
#pod
#pod Given:
#pod
#pod =over
#pod
#pod =item a "source" JSON schema (will not be mutated)
#pod
#pod =item a JSON Pointer into the source schema, from which to be copied
#pod
#pod =back
#pod
#pod will return another, copied standalone JSON schema, with any C<$ref>
#pod either copied in, or if previously encountered, with a C<$ref> to the
#pod new location.
#pod
#pod =cut

sub copy_inline_refs {
    my ( $schema, $pointer, $usschema, $uspointer, $refmap ) = @_;
    $usschema //= Mojo::JSON::Pointer->new( $schema )->get( $pointer );
    $uspointer //= '';
    $refmap ||= {};
    return { '$ref' => $refmap->{ $uspointer } } if $refmap->{ $uspointer };
    $refmap->{ $pointer } = "#$uspointer"
        unless ref $usschema eq 'HASH' and $usschema->{'$ref'};
    return $usschema
        unless ref $usschema eq 'ARRAY' or ref $usschema eq 'HASH';
    my $counter = 0;
    return [ map copy_inline_refs(
        $schema,
        $pointer.'/'.$counter++,
        $_,
        $uspointer.'/'.$counter++,
        $refmap,
    ), @$usschema ] if ref $usschema eq 'ARRAY';
    # HASH
    my $ref = $usschema->{'$ref'};
    return { map { $_ => copy_inline_refs(
        $schema,
        $pointer.'/'.$_,
        $usschema->{ $_ },
        $uspointer.'/'.$_,
        $refmap,
    ) } sort keys %$usschema } if !$ref;
    $ref =~ s:^#::;
    return { '$ref' => $refmap->{ $ref } } if $refmap->{ $ref };
    copy_inline_refs(
        $schema,
        $ref,
        Mojo::JSON::Pointer->new( $schema )->get( $ref ),
        $uspointer,
        $refmap,
    );
}

#pod =sub match
#pod
#pod     my $bool = match( $where, $item );
#pod
#pod Test if the given C<$item> matches the given L C<$where>
#pod data structure. See L for the full syntax.
#pod
#pod Not all of SQL::Abstract's syntax is supported yet, so patches are welcome.
#pod
#pod =cut

sub match {
    my ( $match, $item ) = @_;
    return undef if !defined $item;

    if ( ref $match eq 'ARRAY' ) {
        return any { match( $_, $item ) } @$match;
    }

    my %test;
    for my $key ( keys %$match ) {
        if ( $key =~ /^-(not_)?bool/ ) {
            my $want_false = $1;
            $key = $match->{ $key }; # the actual field
            $test{ $key } = sub {
                my ( $value, $key ) = @_;
                return $want_false ? !$value : !!$value;
            };
        }
        elsif ( !ref $match->{ $key } ) {
            $test{ $key } = $match->{ $key };
        }
        elsif ( ref $match->{ $key } eq 'HASH' ) {
            if ( my $value = $match->{ $key }{ -like } || $match->{ $key }{ like } ) {
                $value = quotemeta $value;
                $value =~ s/(?
                $test{ $key } = qr{^$value$};
            }
            elsif ( $value = $match->{ $key }{ -has } ) {
                my $expect = $value;
                $test{ $key } = sub {
                    my ( $value, $key ) = @_;
                    return 0 if !defined $value;
                    if ( ref $value eq 'ARRAY' ) {
                        if ( ref $expect eq 'ARRAY' ) {
                            return all { my $e = $_; any { $_ eq $e } @$value } @$expect;
                        }
                        elsif ( !ref $expect ) {
                            return any { $_ eq $expect } @$value;
                        }
                    }
                    elsif ( ref $value eq 'HASH' ) {
                        if ( ref $expect eq 'HASH' ) {
                            return match( $expect, $value );
                        }
                        else {
                            die 'Bad query in -has on hash value: ' . ref $expect;
                        }
                    }
                    else {
                        die '-has query does not work on non-ref fields';
                    }
                };
            }
            elsif ( $value = $match->{ $key }{ -not_has } ) {
                $test{ $key } = sub {
                    my $expect = $value;
                    my ( $value, $key ) = @_;
                    return 1 if !defined $value;
                    if ( ref $value eq 'ARRAY' ) {
                        if ( ref $expect eq 'ARRAY' ) {
                            return all { my $e = $_; none { $_ eq $e } @$value } @$expect;
                        }
                        elsif ( !ref $expect ) {
                            return none { $_ eq $expect } @$value;
                        }
                        else {
                            die 'Bad query in -has on array value: ' . ref $expect;
                        }
                    }
                    elsif ( ref $value eq 'HASH' ) {
                        if ( ref $expect eq 'HASH' ) {
                            return !match( $expect, $value );
                        }
                        else {
                            die 'Bad query in -has on hash value: ' . ref $expect;
                        }
                    }
                    else {
                        die '-has query does not work on non-ref fields';
                    }
                };
            }
            elsif ( exists $match->{ $key }{ '!=' } ) {
                my $expect = $match->{ $key }{ '!=' };
                $test{ $key } = sub {
                    my ( $got, $key ) = @_;
                    if ( !defined $expect || !defined $got) {
                        return defined $got != defined $expect;
                    }
                    return $got ne $expect;
                };
            }
            else {
                die "Unimplemented query type: " . to_json( $match->{ $key } );
            }
        }
        elsif ( ref $match->{ $key } eq 'ARRAY' ) {
            my @tests = @{ $match->{ $key } };
            # Array is an 'OR' combiner
            $test{ $key } = sub {
                my ( $value, $key ) = @_;
                my $sub_item = { $key => $value };
                return any { match( { $key => $_ }, $sub_item ) } @tests;
            };
        }
        else {
            die "Unimplemented match ref type: " . to_json( $match->{ $key } );
        }
    }

    my $passes
        = grep {
            !defined $test{ $_ } ? !defined $item->{ $_ }
            : ref $test{ $_ } eq 'Regexp' ? $item->{ $_ } =~ $test{ $_ }
            : ref $test{ $_ } eq 'CODE' ? $test{ $_ }->( $item->{ $_ }, $_ )
            : ($item->{ $_ }//'') eq ($test{ $_ }//'')
        }
        keys %test;

    return $passes == keys %test;
}

#pod =sub order_by
#pod
#pod     my $ordered_array = order_by( $order_by, $unordered_array );
#pod
#pod Order the given arrayref by the given L order-by clause.
#pod
#pod =cut

sub order_by {
    my ( $order_by, $unordered ) = @_;
    # Array of [ (-asc/-desc), (field) ]
    my @sort_items;

    if ( ref $order_by eq 'ARRAY' ) {
        @sort_items = map { [ ref $_ ? %$_ : ( -asc => $_ ) ] } @$order_by;
    }
    elsif ( ref $order_by eq 'HASH' ) {
        @sort_items = [ %$order_by ];
    }
    else {
        @sort_items = [ -asc => $order_by ];
    }

    my @ordered = sort {
            for my $item ( @sort_items ) {
                my $cmp = $item->[0] eq '-asc'
                    ? ($a->{ $item->[1] }//'') cmp ($b->{ $item->[1] }//'')
                    : ($b->{ $item->[1] }//'') cmp ($a->{ $item->[1] }//'')
                    ;
                return $cmp || next;
            }
        }
        @$unordered;

    return \@ordered;
}

#pod =sub fill_brackets
#pod
#pod     my $string = fill_brackets( $template, $item );
#pod
#pod This routine will fill in the given template string with the values from
#pod the given C<$item> hashref. The template contains field names within curly braces.
#pod Values in the C<$item> hashref will be escaped with L.
#pod
#pod     my $item = {
#pod         name => 'Doug Bell',
#pod         email => '[e-mail]',
#pod         quote => 'I <3 Perl',
#pod     };
#pod
#pod     # Doug Bell
#pod     fill_brackets( '{name} <{email}>', $item );
#pod
#pod     # I <3 Perl
#pod     fill_brackets( '{quote}', $item );
#pod
#pod =cut

sub fill_brackets {
    my ( $template, $item ) = @_;
    return scalar $template =~ s/(?{$1}/reg;
}

#pod =sub is_type
#pod
#pod     my $bool = is_type( $schema->{properties}{myprop}{type}, 'boolean' );
#pod
#pod Returns true if the given JSON schema type value (which can be a string or
#pod an array of strings) contains the given value, allowing the given type for
#pod the property.
#pod
#pod     # true
#pod     is_type( 'boolean', 'boolean' );
#pod     is_type( [qw( boolean null )], 'boolean' );
#pod     # false
#pod     is_type( 'string', 'boolean' );
#pod     is_type( [qw( string null )], 'boolean' );
#pod
#pod =cut

sub is_type {
    my ( $type, $is_type ) = @_;
    return unless $type;
    return ref $type eq 'ARRAY'
        ? !!grep { $_ eq $is_type } @$type
        : $type eq $is_type;
}

#pod =sub is_format
#pod
#pod     my $bool = is_format( $schema->{properties}{myprop}{format}, 'date-time' );
#pod
#pod Returns true if the given JSON schema format value (a string) is the given value.
#pod
#pod     # true
#pod     is_format( 'date-time', 'date-time' );
#pod     # false
#pod     is_format( 'email', 'date-time' );
#pod
#pod =cut

sub is_format {
    my ( $format, $is_format ) = @_;
    return unless $format;
    return $format eq $is_format;
}

#pod =sub derp
#pod
#pod     derp "This feature is deprecated in file '%s'", $file;
#pod
#pod Print out a deprecation message as a warning. A message will only be
#pod printed once for each set of arguments from each caller.
#pod
#pod =cut

our @CARP_NOT = qw(
    Yancy::Controller::Yancy Yancy::Controller::Yancy::MultiTenant
    Mojolicious::Plugin::Yancy Mojolicious::Plugins Mojolicious
    Mojo::Server Yancy::Plugin::Editor Yancy::Plugin::Auth
    Mojolicious::Renderer Yancy::Plugin::Auth::Token
    Yancy::Plugin::Auth::Password
);
our %DERPED;
sub derp(@) {
    my @args = @_;
    my $key = to_json [ caller, @args ];
    return if $DERPED{ $key };
    if ( $args[0] !~ /\.$/ ) {
        $args[0] .= '.';
    }
    carp sprintf( $args[0], @args[1..$#args] );
    $DERPED{ $key } = 1;
}

#pod =sub json_validator
#pod
#pod     my $json_validator = json_validator( $schema );
#pod
#pod Build a L object for the given schema, adding all the
#pod necessary attributes.
#pod
#pod =cut

sub json_validator {
    my ( $schema ) = @_;
    my $v = JSON::Validator->new( coerce => 'bool,def,num,str' );
    my $formats = $v->formats;
    $formats->{ password } = sub { undef };
    $formats->{ filepath } = sub { undef };
    $formats->{ markdown } = sub { undef };
    $formats->{ tel } = sub { undef };
    $formats->{ textarea } = sub { undef };
    return $v;
}

1;

__END__