view release on metacpan or  search on metacpan

lib/MQUL.pm  view on Meta::CPAN

##############################################
# _has_adv_que( \%hash )                     #
# ========================================== #
# $hash - the hash-ref to search in          #
# ------------------------------------------ #
# returns true if the hash-ref has any of    #
# the lang's advanced query operators        #
##############################################

sub _has_adv_que {
    my $hash = shift;

    foreach (
        '$gt', '$gte', '$lt', '$lte', '$all',  '$exists', '$mod',
        '$eq', '$ne',  '$in', '$nin', '$size', '$type'
      )
    {
        return 1 if exists $hash->{$_};
    }

    return;
}

##############################################
# _value_in( $value, \@array )               #
# ========================================== #
# $value - the value to check for            #
# $array - the array to search in            #
# ------------------------------------------ #
# returns true if the value is one of the    #
# values from the array.                     #
##############################################

sub _value_in {
    my ( $value, $array ) = @_;

    foreach (@$array) {
        next     if is_float($_)  && !is_float($value);
        next     if !is_float($_) && is_float($value);
        return 1 if is_float($_)  && $value == $_;
        return 1 if !is_float($_) && $value eq $_;
    }

    return;
}

=head2 update_doc( \%document, \%update )

Receives a document hash-ref and an update hash-ref, and updates the
document in-place according to the update hash-ref. Also returns the document
after the update. If the update hash-ref doesn't have any of the update
modifiers described by the language, then the update hash-ref is considered
as what the document should now be, and so will simply replace the document
hash-ref (once again, in accordance with MongoDB).

See L<MQUL::Reference/"UPDATE STRUCTURE"> to learn about the structure of
update hash-refs.

=cut

sub update_doc {
    my ( $doc, $obj ) = @_;

    croak "MQUL::update_doc() requires a document hash-ref."
      unless defined $doc && ref $doc && ref $doc eq 'HASH';
    croak "MQUL::update_doc() requires an update hash-ref."
      unless defined $obj && ref $obj && ref $obj eq 'HASH';

    # we only need to do something if the $obj hash-ref has any advanced
    # update operations, otherwise $obj is meant to be the new $doc

    if ( &_has_adv_upd($obj) ) {
        foreach my $op ( keys %$obj ) {
            if ( $op eq '$inc' ) {

                # increase numerically
                next unless ref $obj->{$op} eq 'HASH';
                foreach my $field ( keys %{ $obj->{$op} } ) {
                    $doc->{$field} ||= 0;
                    $doc->{$field} += $obj->{$op}->{$field};
                }
            } elsif ( $op eq '$set' ) {

                # set key-value pairs
                next unless ref $obj->{$op} eq 'HASH';
                foreach my $field ( keys %{ $obj->{$op} } ) {
                    $doc->{$field} = $obj->{$op}->{$field};
                }
            } elsif ( $op eq '$unset' ) {

                # remove key-value pairs
                next unless ref $obj->{$op} eq 'HASH';
                foreach my $field ( keys %{ $obj->{$op} } ) {
                    delete $doc->{$field} if $obj->{$op}->{$field};
                }
            } elsif ( $op eq '$rename' ) {

                # rename attributes
                next unless ref $obj->{$op} eq 'HASH';
                foreach my $field ( keys %{ $obj->{$op} } ) {
                    $doc->{ $obj->{$op}->{$field} } = delete $doc->{$field}
                      if exists $doc->{$field};
                }
            } elsif ( $op eq '$push' ) {

                # push values to end of arrays
                next unless ref $obj->{$op} eq 'HASH';
                foreach my $field ( keys %{ $obj->{$op} } ) {
                    croak "The $field attribute is not an array in the doc."
                      if defined $doc->{$field}
                      && ref $doc->{$field} ne 'ARRAY';
                    $doc->{$field} ||= [];
                    push( @{ $doc->{$field} }, $obj->{$op}->{$field} );
                }
            } elsif ( $op eq '$pushAll' ) {

                # push a list of values to end of arrays
                next unless ref $obj->{$op} eq 'HASH';
                foreach my $field ( keys %{ $obj->{$op} } ) {
                    croak "The $field attribute is not an array in the doc."
                      if defined $doc->{$field}