view release on metacpan or  search on metacpan

lib/FSM/Basic.pm  view on Meta::CPAN

package FSM::Basic;

use 5.010;
use strict;
use warnings;

use Carp;

use Data::Dumper;

our $VERSION = '0.28';

sub new {
    my ($class, $l, $s) = @_;
    my $self;
    $self->{states_list} = $l;
    $self->{state}       = $s;
    foreach my $k1 (keys %{ $self->{states_list} }) {
        if (exists $self->{states_list}{$k1}{expect}) {
            foreach my $k2 (keys %{ $self->{states_list}{$k1}{expect} }) {
                if (ref $self->{states_list}{$k1}{expect}{$k2} eq 'HASH'
                    && exists $self->{states_list}{$k1}{expect}{$k2}{alternation})
                {
                    if (defined $self->{states_list}{$k1}{expect}{$k2}{caseinsensitive}) {
                        $self->{states_list}{$k1}{expect}{ alter($k2, 1) } = delete $self->{states_list}{$k1}{expect}{$k2};
                    } else {
                        $self->{states_list}{$k1}{expect}{ alter($k2) } = delete $self->{states_list}{$k1}{expect}{$k2};
                    }
                }
            }
        }
    }
    bless($self, $class);
    return $self;
}

my @commands = qw(
  cmd
  cmd_exec
  exec
  cmd_regex
  do
  output
  output_file
  cat
  more
  catrand
  catwrand
  catseq
  catseq_idx
  catseqn
  swapregex
  matching
  final
  matching
  caseinsensitive
  alternation
);


sub qp(&){
    my $s;
    open local *STDOUT, '>', \$s or die "open in-memory file: $!";
    &{$_[0]};
    die $@ if $@;
    $s;
}

sub run {
    my ($self, $in) = @_;
    my $in_lc = lc($in);
    $in =~ s/([*?.])/\\$1/g;
    my $rev;
    my %extra;
    if ($in !~ /^$/) {
        foreach my $IN (grep { /^$in/i } keys %{ $self->{states_list}{ $self->{state} }{expect} }) {
            if (ref $self->{states_list}{ $self->{state} }{expect}{$IN} eq 'HASH') {
                $rev //= $IN if (defined $self->{states_list}{ $self->{state} }{expect}{$IN}{swapregex});
                foreach my $key (keys %{ $self->{states_list}{ $self->{state} }{expect}{$IN} }) {
                    # carp "k=$key IN=$IN";
                    $extra{$key} = $self->{states_list}{ $self->{state} }{expect}{$IN}{$key} unless any($key);
                }
            }
        }
    }
    # carp "state=".Dumper($self->{states_list});
    my $output = '';
    my $string;
    if (exists $self->{states_list}) {
        if (   exists $self->{states_list}{ $self->{state} }
            && exists $self->{states_list}{ $self->{state} }{repeat}
            && $self->{states_list}{ $self->{state} }{repeat} <= 0)
        {
            $self->{previous_state} = $self->{state};
            $self->{state}          = $self->{states_list}{ $self->{state} }{expect}{not_matching0} // $self->{states_list}{ $self->{state} }{not_matching0};
            if (exists $self->{states_list}{ $self->{previous_state} }{not_matching_info_last}) {
                $output = $self->{states_list}{ $self->{previous_state} }{not_matching_info_last};
            }
            $output .= $self->{states_list}{ $self->{state} }{output} // read_file($self->{states_list}{ $self->{state} }{output_file}) // '';
            return ($self->{states_list}{ $self->{state} }{final} // 0, $output);
        }
        if (exists $self->{states_list}{ $self->{state} }{expect}) {
            if (exists $self->{states_list}{ $self->{state} }{info}) {
                $output = $self->{states_list}{ $self->{state} }{info} . $output;
            }
            if (exists $self->{states_list}{ $self->{state} }{info_once}) {
                $output = delete($self->{states_list}{ $self->{state} }{info_once}) . $output;
            }
            my $state;
            if (   exists $self->{previous_output}
                && $in eq ''
                && $self->{previous_output} =~ /\[(.+)\]/)
            {
                $in = $1;
            }
            my $match;
            if (defined $rev) {
                my $key = $rev;
                my $r   = $in;
                $r = '(?i:' . $r . ')' if defined $self->{states_list}{ $self->{state} }{expect}{$rev}{caseinsensitive};
                if ($r && $key =~ /^$r/) {