view release on metacpan or  search on metacpan

lib/Net/CLI/Interact/Phrasebook.pm  view on Meta::CPAN

    $self->logger->log('phrasebook', 'debug', 'storing', $data->{type}, $data->{name});

    my $slot = '_'. lc $data->{type};
    $self->$slot->{$data->{name}}
        = Net::CLI::Interact::ActionSet->new({
            actions => $self->_resolve_matches($data->{actions})
        });
}

sub BUILD {
    my $self = shift;
    $self->load_phrasebooks;
}

# parse phrasebook files and load action objects
sub load_phrasebooks {
    my $self = shift;
    my $data = {};
    my $stash = { prompt => [], macro => [] };

    foreach my $file ($self->_find_phrasebooks) {
        $self->logger->log('phrasebook', 'info', 'reading phrasebook', $file);
        my @lines = $file->slurp;
        while ($_ = shift @lines) {
            # Skip comments and empty lines
            next if m/^(?:#|\s*$)/;

            if (m{^(prompt|macro)\s+(\w+)\s*$}) {
                if (scalar keys %$data) {
                    push @{ $stash->{$data->{type}} }, $data;
                }
                $data = {type => $1, name => $2};
                next;
            }
            # skip new sections we don't yet understand
            elsif (m{^\w}) {
                $_ = shift @lines until m{^(?:prompt|macro)};
                unshift @lines, $_;
                next;
            }

            if (m{^\s+send\s+(.+)$}) {
                my $value = $1;
                $value =~ s/^["']//; $value =~ s/["']$//;
                push @{ $data->{actions} }, {
                    type => 'send', value => $value,
                };
                next;
            }

            if (m{^\s+put\s+(.+)$}) {
                my $value = $1;
                $value =~ s/^["']//; $value =~ s/["']$//;
                push @{ $data->{actions} }, {
                    type => 'send', value => $value, no_ors => 1,
                };
                next;
            }

            if (m{^\s+match\s+(.+)\s*$}) {
                my @vals = split m/\s+or\s+/, $1;
                if (scalar @vals) {
                    push @{ $data->{actions} },
                        {type => 'match', value => \@vals};
                    next;
                }
            }

            if (m{^\s+follow\s+/(.+)/\s+with\s+(.+)\s*$}) {
                my ($match, $send) = ($1, $2);
                $send =~ s/^["']//; $send =~ s/["']$//;
                $data->{actions}->[-1]->{continuation} = [
                    {type => 'match', value => [qr/$match/]},
                    ## no critic (ProhibitStringyEval)
                    {type => 'send',  value => eval "qq{$send}", no_ors => 1}
                    ## use critic
                ];
                next;
            }

            die "don't know what to do with this phrasebook line:\n", $_;
        }
        # last entry in the file needs baking
        push @{ $stash->{$data->{type}} }, $data;
        $data = {};
    }

    # bake the prompts before the macros, to allow macros to reference
    # prompts which appear later in the same file.
    foreach my $t (qw/prompt macro/) {
        foreach my $d (@{ $stash->{$t} }) {
            $self->_bake($d);
        }
    }
}

# finds the path of Phrasebooks within the Library leading to Personality
sub _find_phrasebooks {
    my $self = shift;
    my @libs = (ref $self->library ? @{$self->library} : ($self->library));
    my @alib = (ref $self->add_library ? @{$self->add_library} : ($self->add_library));

    # first find the (relative) path for the requested personality
    # then within each of @libs gather the files along that path

    my $target = $self->_find_personality_in( @libs, @alib );
    die (sprintf "error: unknown personality: '%s'\n",
            $self->personality) unless $target;

    my @files = $self->_gather_pb_from( $target, @libs, @alib );
    die (sprintf "error: personality '%s' contains no phrasebook files!\n",
            $self->personality) unless scalar @files;

    return @files;
}

sub _find_personality_in {
    my ($self, @libs) = @_;
    my $target = undef;

    foreach my $lib (@libs) {