File Coverage

blib/lib/Inline/Spew.pm

Criterion	Covered	Total	%
statement	64	69	92.7
branch	15	26	57.6
condition	3	4	75.0
subroutine	11	12	91.6
pod	6	6	100.0
total	99	117	84.6

package Inline::Spew;

use 5.006;
use strict;
use warnings;

require Exporter;
require Inline;
require YAML;

our @ISA = qw(Inline Exporter);

our %EXPORT_TAGS = ( 'all' => [ qw(

) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(

);

our $VERSION = '0.02';

sub register {
  return {
	  language => 'Spew',
	  type => 'interpreted',
	  suffix => 'spew',
	 };
}

sub validate {
  ## warn "validate called with:\n", YAML::Dump(@_), "\n\n";
}

sub build {
  my $o = shift;
  my $code = $o->{API}{code};
  my $location = "$o->{API}{location}";

  require File::Basename;
  my $directory = File::Basename::dirname($location);
  $o->mkpath($directory) unless -d $directory;

  my $spew = spew_compile($code);

  YAML::DumpFile($location, $spew);
}

sub load {
  my $o = shift;

  my $sub = do {
    my $s = $o->{CONFIG}{SUB} || "spew";
    unless ($s =~ /::/) {
      $s = $o->{API}{pkg}."::$s";
    }
    $s;
  };
  my $location = $o->{API}{location};
  my @result = YAML::LoadFile($location);

  {
    no strict 'refs';
    *$sub = sub {
      my $start = shift || "START";
      return spew_show($result[0], $start);
    };
  }
}

sub spew_show {
  my ($parsed, $defn) = @_;
  die "missing defn for $defn" unless exists $parsed->{$defn};

  my @choices = @{$parsed->{$defn}{is}};
  my $weight = 0;
  my @keeper = ();
  while (@choices) {
    my ($thisweight, @thisitem) = @{pop @choices};
    $thisweight = 0 if $thisweight < 0; # no funny stuff
    $weight += $thisweight;
    @keeper = @thisitem if rand($weight) < $thisweight;
  }
  my $result;
  for (@keeper) {
    ## should be a list of ids or defns
    die "huh $_ in $defn" if ref $defn;
    if (/^ (.*)/s) {
      $result .= $1;
    } elsif (/^(\w+)$/) {
      $result .= spew_show($parsed, $1);
    } else {
      die "Can't show $_ in $defn\n";
    }
  }
  return $result;
}

BEGIN {

  my $parser;
  my $GRAMMAR = q{
## return hashref
## { ident => {
##     is => [
##       [weight => item, item, item, ...],
##       [weight => item, item, item, ...], ...
##     ],
##     defined => { line-number => times }
##     used => { line-number => times }
##   }, ...
## }
## item is " literal" or ident
## ident is C-symbol or number (internal for nested rules)

{ my %grammar; my $internal = 0; }

grammar: rule(s) /\Z/ { \%grammar; }

## rule returns identifier (not used)
rule: identifier ":" defn {
                push @{$grammar{$item[1]}{is}}, @{$item[3]};
                $grammar{$item[1]}{defined}{$itempos[1]{line}{to}}++;
                $item[1];
        }
        |

## defn returns listref of choices
defn:

## choice returns a listref of [weight => @items]
choice: weight unweightedchoice { [ $item[1] => @{$item[2]} ] }

## weight returns weight if present, 1 if not
weight: /\d+(\.\d+)?/  /\@/ { $item[1] } | { 1 }

## unweightedchoice returns a listref of @items
unweightedchoice: item(s)

## item returns " literal text" or "identifier"
item:
        { $_ = extract_quotelike($text) and " " . eval }
        | identifier  ...!/:/ { # must not be followed by colon!
                $grammar{$item[1]}{used}{$itempos[1]{line}{to}}++;
                $item[1]; # non-leading space flags an identifier
        }
        | "(" defn ")" { # parens for recursion, gensym an internal
                ++$internal;
                push @{$grammar{$internal}{is}}, @{$item[2]};
                $internal;
        }
        |

identifier: /[^\W\d]\w*/
};

  sub spew_compile {
    my $source = shift;

    unless ($parser) {
      require Parse::RecDescent;
      $parser = Parse::RecDescent->new($GRAMMAR) or die "internal bad";
    }

    my $parsed = $parser->grammar($source) or die "bad spew grammar";

    for my $id (sort keys %$parsed) {
      next if $id =~ /^\d+$/;       # skip internals
      my $id_ref = $parsed->{$id};
      unless (exists $id_ref->{defined}) {
	die "$id used in @{[sort keys %{$id_ref->{used}}]} but not defined";
      }
      ## unless (exists $id_ref->{used} or $id eq $START) {
      ## warn "$id defined in @{[sort keys %{$id_ref->{defined}}]} but not used";
      ## }
    }

    return $parsed;
  }
}

1;
__END__