File Coverage

blib/lib/CXC/Data/Visitor.pm

Criterion	Covered	Total	%
statement	200	201	99.5
branch	87	110	79.0
condition	18	29	62.0
subroutine	22	22	100.0
pod	1	1	100.0
total	328	363	90.3

package CXC::Data::Visitor;

# ABSTRACT: Invoke a callback on every element at every level of a data structure.

use v5.20;
use strict;
use warnings;


use feature 'current_sub';
use experimental 'signatures', 'lexical_subs', 'postderef';

#<<< no tidy
our $VERSION = '0.12';
#>>>

use base 'Exporter::Tiny';
use Hash::Util 'lock_hash', 'unlock_hash', 'unlock_value';
use POSIX 'floor';
use Scalar::Util 'refaddr', 'looks_like_number';
use Ref::Util 'is_plain_arrayref', 'is_plain_hashref', 'is_coderef', 'is_plain_ref',
  'is_plain_refref';
use Feature::Compat::Defer;

use constant {
    CYCLE_DIE      => 'die',
    CYCLE_CONTINUE => 'continue',
    CYCLE_TRUNCATE => 'truncate',
};
use constant CYCLE_QR => qr /\A die|continue|truncate \z/x;
use constant {
    VISIT_HASH      => 0b0001,
    VISIT_ARRAY     => 0b0010,
    VISIT_CONTAINER => 0b0011,
    VISIT_LEAF      => 0b0100,
    VISIT_ALL       => 0b0111,
    VISIT_ROOT      => 0b1000,
};
use constant {
    RESULT_NULL              => 0b000000,
    RESULT_RETURN            => 0b000001,
    RESULT_CONTINUE          => 0b000010,
    RESULT_REVISIT_CONTENTS  => 0b000100,
    RESULT_REVISIT_CONTAINER => 0b000100,    # back compat
    RESULT_REVISIT_ELEMENT   => 0b001000,
    RESULT_STOP_DESCENT      => 0b010000,
    RESULT_REVISIT_ROOT      => 0b100000,
};

use constant {
    PASS_VISIT_ELEMENT   => 0b01,
    PASS_REVISIT_ELEMENT => 0b10,
};

our %EXPORT_TAGS = (
    funcs   => [qw( visit )],
    results => [ qw(
          RESULT_NULL
          RESULT_RETURN
          RESULT_CONTINUE
          RESULT_REVISIT_ROOT
          RESULT_REVISIT_CONTENTS
          RESULT_REVISIT_CONTAINER
          RESULT_REVISIT_ELEMENT
          RESULT_STOP_DESCENT
        ),
    ],

    cycles => [ qw(
          CYCLE_DIE
          CYCLE_CONTINUE
          CYCLE_TRUNCATE
        ),
    ],

    visits => [ qw(
          VISIT_ARRAY
          VISIT_HASH
          VISIT_CONTAINER
          VISIT_LEAF
          VISIT_ALL
          VISIT_ROOT
        ),
    ],

    passes => [ qw(
          PASS_VISIT_ELEMENT
          PASS_REVISIT_ELEMENT
        ),
    ],

    constants => [qw( :results :cycles :visits :passes )],
);

our @EXPORT_OK = map { $EXPORT_TAGS{$_}->@* } keys %EXPORT_TAGS;

my sub croak {
    require Carp;
    goto \&Carp::croak;
}


## no critic (Subroutines::ProhibitManyArgs  Subroutines::ProhibitExcessComplexity)
my sub visit_node ( $node, $code, $context, $cycle, $visit, $meta ) {

    my $path      = $meta->{path};
    my $ancestors = $meta->{ancestors};

    my $sort_key_mode = $meta->{sort_key_mode};
    my $sort_idx_mode = $meta->{sort_idx_mode};
    my $key_sort      = $meta->{key_sort};
    my $idx_sort      = $meta->{idx_sort};

    my $visit_leaf  = !!( $visit & VISIT_LEAF );
    my $visit_hash  = !!( $visit & VISIT_HASH );
    my $visit_array = !!( $visit & VISIT_ARRAY );

    my $refaddr = refaddr( $node );
    if ( exists $meta->{seen}{$refaddr} ) {

        my $lcycle
          = is_coderef( $cycle )
          ? $cycle->( $node, $context, $meta )
          : $cycle;

        $lcycle eq CYCLE_TRUNCATE and return !!1;
        $lcycle eq CYCLE_DIE
          and croak( __PACKAGE__ . '::visit: cycle detected: ', join( '->', $path->@* ) );

        $lcycle eq CYCLE_CONTINUE
          or croak( __PACKAGE__ . "::visit: unkown cycle parameter value: $lcycle" );
    }

    # after this call to visit_node, will have visited all descendents of
    # $node, so don't need this any longer.
    $meta->{seen}{$refaddr} = ();
    defer { delete $meta->{seen}{$refaddr} }

    my %meta = $meta->%*;
    $meta{container} = $node;

    # deal with bare next in $code body
    use warnings FATAL => 'exiting';

    my $is_hashref = is_plain_hashref( $node );

    push $ancestors->@*, $node;
    defer { pop $ancestors->@* };

    my $revisit_limit = $meta->{revisit_limit};
    @meta{ 'visit', 'idx' } = ( 0, -1 );

  SCAN: {
        last unless --$revisit_limit;

        $meta{visit}++;
        $meta{idx} = -1;

        my $rescan_container = !!0;

        my $kydx_arr = do {

            if ( $is_hashref ) {
                    $sort_key_mode == 0 ? $key_sort->( [ keys $node->%* ] )
                  : $sort_key_mode == 1 ? [ sort keys $node->%* ]
                  :                       [ keys $node->%* ];
            }

            # must be an arrayref
            else {
                $sort_idx_mode == 0
                  ? $idx_sort->( 0+ $node->@* )
                  : [ 0 .. ( $node->@* - 1 ) ];
            }
        };

        for my $kydx ( $kydx_arr->@* ) {
            $meta{idx}++;

            push $path->@*, $kydx;
            defer { pop $path->@* }

            my $vref = \( $is_hashref ? $node->{$kydx} : $node->[$kydx] );

            my $visit_element
              = is_plain_hashref( $$vref )  ? $visit_hash
              : is_plain_arrayref( $$vref ) ? $visit_array
              :                               $visit_leaf;

            my $revisit_element = !!0;

            $meta{pass} = PASS_VISIT_ELEMENT;
            if ( $visit_element
                and ( my $result = $code->( $kydx, $vref, $context, \%meta ) ) != RESULT_CONTINUE )
            {
                # immediate rescan if explicitly set to value,
                # otherwise it will happen after the container is
                # completely visited
                redo SCAN                  if $result == RESULT_REVISIT_CONTENTS;
                return RESULT_RETURN       if $result == RESULT_RETURN;
                return RESULT_REVISIT_ROOT if $result == RESULT_REVISIT_ROOT;

                $rescan_container = $result & RESULT_REVISIT_CONTENTS;

                next if $result & RESULT_STOP_DESCENT;    # this works for both leaves and containers

                $revisit_element = $result & RESULT_REVISIT_ELEMENT;

                croak( "unknown return value from visit: $result" )
                  if !$revisit_element && !$result & RESULT_CONTINUE;
            }

            next unless is_plain_refref( $vref );

            my $ref = $vref->$*;
            if ( is_plain_arrayref( $ref ) || is_plain_hashref( $ref ) ) {
                my $result = __SUB__->( $ref, $code, $context, $cycle, $visit, \%meta );
                return RESULT_RETURN       if $result == RESULT_RETURN;
                return RESULT_REVISIT_ROOT if $result == RESULT_REVISIT_ROOT;
                if ( $revisit_element ) {
                    $meta{pass} = PASS_REVISIT_ELEMENT;
                    $result = $code->( $kydx, $vref, $context, \%meta );
                    return RESULT_RETURN       if $result == RESULT_RETURN;
                    return RESULT_REVISIT_ROOT if $result == RESULT_REVISIT_ROOT;
                    croak( "unexpected return value from visit: $result" )
                      if $result & ~( RESULT_CONTINUE | RESULT_REVISIT_CONTENTS );
                    $rescan_container |= $result & RESULT_REVISIT_CONTENTS;
                }
            }
        }
        redo SCAN if $rescan_container;
    }
    croak( "exceeded limit ($meta{revisit_limit}) on revisiting containers" )
      unless $revisit_limit;

    return RESULT_CONTINUE;
}

my sub visit_root ( $root, $code, $context, $cycle, $visit, $meta ) {

    my %meta          = $meta->%*;
    my $revisit_limit = $meta{revisit_limit};
    $meta{pass} = PASS_VISIT_ELEMENT;
    @meta{ 'visit', 'idx' } = ( 0, 0 );

  FROOT_LOOP:
    {
        $meta{visit}++;
        last unless --$revisit_limit;

        my $result = $code->( undef, \$root, $context, \%meta );

        redo FROOT_LOOP if $result == RESULT_REVISIT_ROOT;

        return !!0 if $result == RESULT_RETURN;
        return !!1 if $result == RESULT_STOP_DESCENT;

        my $revisit_element = $result & RESULT_REVISIT_ELEMENT;

        croak( "unknown return value from visit: $result" )
          if !$revisit_element && !$result & RESULT_CONTINUE;

        my $status = visit_node( $root, $code, $context, $cycle, $visit, \%meta );
        return !!0 if $status == RESULT_RETURN;

        if ( $revisit_element ) {
            $meta{pass} = PASS_REVISIT_ELEMENT;
            $result = $code->( undef, \$root, $context, \%meta );
            return !!0 if $result == RESULT_RETURN;
            return !!1 if $result == RESULT_CONTINUE;
            croak( "unexpected return value while revisiting root: $result" );
        }
    }
    croak( "exceeded limit ($meta{revisit_limit}) while revisiting root" )
      unless $revisit_limit;

    return !!1;
}



## critic (Subroutines::ProhibitManyArgs  Subroutines::ProhibitExcessComplexity)
sub visit ( $root, $callback, %opts ) {

    is_coderef( $callback )
      or croak( q{parameter 'callback' must be a coderef} );

    my $context = delete $opts{context} // {};

    # back compat
    if ( defined( my $sort_keys = delete $opts{sort_keys} ) ) {
        croak( q{specify only one of 'key_sort' or 'sort_keys'} )
          if defined $opts{key_sort};

        $opts{key_sort} = is_coderef( $sort_keys )
          ? sub ( $array ) {
            [ sort { $sort_keys->( $a, $b ) } $array->@* ];
          }
          : $sort_keys;
    }

    croak( "illegal value for 'revisit_limit' : $opts{revisit_limit}" )
      if defined $opts{revisit_limit}
      && !(looks_like_number( $opts{revisit_limit} )
        && floor( $opts{revisit_limit} ) == $opts{revisit_limit} );

    my %metadata = (
        path          => [],
        seen          => {},
        ancestors     => [],
        container     => undef,
        revisit_limit => delete $opts{revisit_limit} // 10,
        key_sort      => delete $opts{key_sort},
        idx_sort      => delete $opts{idx_sort},
    );

    {
        my $key_sort = $metadata{key_sort};
        my $idx_sort = $metadata{idx_sort};

        # $sort_key_mode =
        #  0 if passed coderef
        #  1 if should sort
        #  2 if should not sort
        $metadata{sort_key_mode}
          = defined $key_sort ? ( is_coderef( $key_sort ) ? 0 : $key_sort ? 1 : 2 ) : 1;

        # sorting indices is different than sorting keys,
        # as unlike for keys, indices are intrinsicly sorted

        # $sort_idx_modes =
        #  0 if passed coderef
        #  1 otherwise
        $metadata{sort_idx_mode} = defined( $idx_sort ) && is_coderef( $idx_sort ) ? 0 : 1;
    }

    my $cycle = delete $opts{cycle} // 'die';
    my $visit = delete $opts{visit} // VISIT_ALL;
    $visit |= VISIT_ALL if $visit == VISIT_ROOT;

    $cycle =~ CYCLE_QR
      or croak( "illegal value for cycle parameter: $cycle" );

    %opts
      and croak( 'illegal parameters: ', join( q{, }, keys %opts ) );

    lock_hash( %metadata );
    unlock_value( %metadata, 'container' );

    my $completed;

    if ( $visit & VISIT_ROOT ) {
        $completed = visit_root( $root, $callback, $context, $cycle, $visit, \%metadata );
    }
    else {
        my $revisit_limit = $metadata{revisit_limit};
        while ( --$revisit_limit ) {
            last unless --$revisit_limit;
            $completed = visit_node( $root, $callback, $context, $cycle, $visit, \%metadata );
            last unless $completed == RESULT_REVISIT_ROOT;
        }
        croak( "exceeded limit ($metadata{revisit_limit}) while revisiting root" )
          unless $revisit_limit;
        $completed = $completed != RESULT_RETURN;
    }

    unlock_hash( %metadata );

    delete $metadata{ancestors};    # should be empty, but just in case,
                                    # don't want to keep references
                                    # around.

    return ( $completed, $context, \%metadata );
}

1;

#
# This file is part of CXC-Data-Visitor
#
# This software is Copyright (c) 2024 by Smithsonian Astrophysical Observatory.
#
# This is free software, licensed under:
#
#   The GNU General Public License, Version 3, June 2007
#

__END__