File Coverage

blib/lib/CXC/Data/Visitor.pm

Criterion	Covered	Total	%
statement	130	132	98.4
branch	43	58	74.1
condition	15	20	75.0
subroutine	20	20	100.0
pod	1	1	100.0
total	209	231	90.4

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

our $VERSION = '0.08';

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      => 0b001,
    VISIT_ARRAY     => 0b010,
    VISIT_CONTAINER => 0b011,
    VISIT_LEAF      => 0b100,
    VISIT_ALL       => 0b111,
};
use constant {
    RESULT_RETURN            => 0,
    RESULT_CONTINUE          => 1,
    RESULT_REVISIT_CONTAINER => 2,
    RESULT_REVISIT_ELEMENT   => 3,
    RESULT_STOP_DESCENT      => 4,
};

use constant { PASS_VISIT_ELEMENT => 1, PASS_REVISIT_ELEMENT => 2 };

our %EXPORT_TAGS = (
    funcs   => [qw( visit )],
    results => [
        qw( RESULT_RETURN RESULT_CONTINUE 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 )],
    passes    => [qw( PASS_VISIT_ELEMENT PASS_REVISIT_ELEMENT )],
    constants => [qw( :results :cycles :visits )],
);

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, $code, $context, $cycle, $visit, $meta ) {

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

    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, 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 $visit_leaf  = !!( $visit & VISIT_LEAF );
    my $visit_hash  = !!( $visit & VISIT_HASH );
    my $visit_array = !!( $visit & VISIT_ARRAY );

  SCAN: {
        last unless --$revisit_limit;

        my @idx
          = $is_hashref
          ? (
            $meta->{sort_keys}
            ? ( sort { $meta->{sort_keys}->( $a, $b ) } keys $node->%* )
            : sort keys $node->%*
          )
          : keys $node->@*;

        for my $idx ( @idx ) {

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

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

            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->( $idx, $vref, $context, \%meta ) ) != RESULT_CONTINUE )
            {
                redo SCAN  if $result == RESULT_REVISIT_CONTAINER;
                return !!0 if $result == RESULT_RETURN;
                next       if $result == RESULT_STOP_DESCENT;        # this works for both leaves and containers

                if ( $result == RESULT_REVISIT_ELEMENT ) {
                    $revisit_element = !!1;
                }
                elsif ( $result != RESULT_CONTINUE ) {
                    croak( "unknown return value from visit: $result" );
                }
            }

            next unless is_plain_refref( $vref );

            my $ref = $vref->$*;
            if ( is_plain_arrayref( $ref ) || is_plain_hashref( $ref ) ) {
                __SUB__->( $ref, $code, $context, $cycle, $visit, \%meta ) || return !!0;

                if ( $revisit_element ) {
                    $meta{pass} = PASS_REVISIT_ELEMENT;
                    my $result = $code->( $idx, $vref, $context, \%meta );
                    return !!0 if $result == RESULT_RETURN;
                    next       if $result == RESULT_CONTINUE;
                    croak( "unknown return value from visit: $result" );
                }
            }
        }
    }
    croak( "exceeded limit ($meta->{revisit_limit}) on revisiting containers" )
      unless $revisit_limit;

    return !!1;
}
## critic (Subroutines::ProhibitManyArgs  Subroutines::ProhibitExcessComplexity)



















































































































































































































































sub visit ( $struct, $callback, %opts ) {

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

    croak( q{parameter 'sort_keys' must be a coderef} )
      if exists $opts{sort_keys} && !is_coderef( $opts{sort_keys} );

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

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

    croak( "illegal value for 'revisit_limit' : $metadata{revisit_limit}" )
      unless looks_like_number( $metadata{revisit_limit} )
      && floor( $metadata{revisit_limit} ) == $metadata{revisit_limit};


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

    $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 = _visit( $struct, $callback, $context, $cycle, $visit, \%metadata );
    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__