File Coverage

blib/lib/Text/Fab.pm

Criterion	Covered	Total	%
statement	214	222	96.4
branch	99	124	79.8
condition	16	23	69.5
subroutine	32	33	96.9
pod	9	16	56.2
total	370	418	88.5

package Text::Fab;

use 5.022;
use strict;
use warnings;

our $VERSION = '0.01';

#use Storable 'dclone'; # For group snapshots (does not support CODE references in data!)
use FreezeThaw qw(safeFreeze thaw); # For group snapshots

sub dclone ($) {(thaw safeFreeze shift)[0]}	# return scalar even in scalar content

# --- Default Callbacks ---
# These are the "smart" components that define the default language.
# A user can replace any of these by setting the config hash.

# Finds the start of the next directive.
sub _default_interleaver {
    my ($buffer, $offset) = @_;
    # A directive is a '#' at the beginning of a line.
    # We search for a newline, then check if it's followed by '#'.
    # A special case handles a '#' at the very start of the buffer.
    return 0 if $offset == 0 && substr($buffer, 0, 1) eq '#';
    my $pos = index($buffer, "\n#", $offset-1);
    return $pos == -1 ? undef : $pos + 1;
}

# Parses a directive and calls the corresponding Fab primitive.
sub _default_directive_parser {
    my ($fab, $buffer, $offset) = @_;
    my $line_end = index($buffer, "\n", $offset);
    $line_end = length($buffer) if $line_end == -1;

    my $directive_line = substr($buffer, $offset, $line_end - $offset);
#    warn("Drctv_ln: <<<$directive_line>>>");

    if ($directive_line =~ /^#(\w+)\s*(.*)/) {
        my ($directive, $args) = (lc $1, $2);
        $args =~ s/\s+$//; # Trim trailing whitespace
#        warn("Drctv: <<<$directive>>>, <<<$args>>>");

        # This dispatch table maps the user-facing syntax to the stable
        # internal API of primitive operations.
        if ($directive eq 'target_section') {
            my ($basename, $ns) = ($args =~ /(\w+)(?:\s+in\s+(\w+))?/);
            $fab->out__target_section($basename, $ns);
        }
        elsif ($directive eq 'set') {
             my ($key, $value) = split /=/, $args, 2;
             $fab->cfg__set($key, $value);
        }
        elsif ($directive eq 'append') {
            my ($key, @values) = split /\s+/, $args;
            $fab->cfg__append($key, @values);
        }
        elsif ($directive eq 'set_parents') {
            my ($ns, @parents) = split /\s+/, $args;
            # The inheritance graph is stored in a structured way in the config.
            $fab->cfg__set("Fab/inheritance_graph/$ns/parents", \@parents);
        }
        elsif ($directive eq 'emb') {
            my ($basename, $ns) = ($args =~ /(\w+)(?:\s+in\s+(\w+))?/);
            $fab->out__embed($basename, $ns, {});
        }
        elsif ($directive eq 'start_group') {
            $fab->group__start($args);
        }
        elsif ($directive eq 'end_group') {
            $fab->group__end($args);
        }
        else {
            $fab->_handle_error('unknown_directive', { directive => $directive, line => $directive_line });
        }
    }
    else {
        $fab->_handle_error('malformed_directive', { line => $directive_line });
    }

    return $line_end + 1; # Resume processing after this directive line.
}

# The default "stomach" - processes text chunks between directives.
sub _default_chunk_preprocessor {
    my ($fab, $chunk) = @_;
    # By default, it does nothing but return the text.
    return $chunk;
}

# The default error handler - fail fast.
sub _default_error_handler {
    my ($fab, $type, $details) = @_;
    die "Fab Error ($type): $details->{line}\n";
}

# --- Core Class ---

sub new {
    my ($class, %args) = @_;
    my $self = bless {}, $class;

    # The entire state of the system is held in these hashes.
    $self->{config} = {
        # Meta-configuration: which keys are lists.
        'Fab/list_keys' => { 'Fab/list_keys' => 1 },
        'Fab/hash_keys' => {},
        'Fab/hash_key_sort_order' => sub { $a cmp $b }, # Default sort for hash keys
        # State for recursive processing.
        'Fab/call_stack_prefixes' => ['Fab/'],
        # The user-configurable components that define the language.
        'Fab/callbacks' => {
            interleaver        => \&_default_interleaver,
            directive_parser   => \&_default_directive_parser,
            chunk_preprocessor => \&_default_chunk_preprocessor,
            error_handler      => \&_default_error_handler,
        },
        # The inheritance graph is just another part of the configuration.
        'Fab/inheritance_graph' => {},
    };
    $self->{sections}       = {}; # { namespace => { basename => \@chunks } }
    $self->{current_target} = ['_main', 'body']; # Default output target.
    $self->{group_stack}    = [];

    # Allow user to provide an initial configuration.
    if ($args{config}) {
        # A real implementation would merge recursively.
        %{$self->{config}} = (%{$self->{config}}, %{$args{config}});
    }

    return $self;
}

# The main processing loop, driven by the callbacks.
sub process_string {
    my ($self, $string) = @_;
    my $offset = 0;

    my $callbacks = $self->cfg__get_prefixed('Fab/callbacks');
    my ($interleaver, $parser, $preprocessor) =
        @{$callbacks}{qw(interleaver directive_parser chunk_preprocessor)};

    while ($offset < length($string)) {
        my $directive_start = $interleaver->($string, $offset);

        if (!defined $directive_start) {
            $self->_process_chunk(substr($string, $offset), $preprocessor);
            last;
        }

        my $chunk_text = substr($string, $offset, $directive_start - $offset);
        $self->_process_chunk($chunk_text, $preprocessor);

        $offset = $parser->($self, $string, $directive_start);
    }
}

sub _process_chunk {
    my ($self, $chunk_text, $preprocessor) = @_;
    # Remove leading newline that results from splitting by `\n#`.
    $chunk_text =~ s/^\n//;
    return unless length $chunk_text;

    my ($ns, $basename) = @{$self->{current_target}};
    my $processed_chunk = $preprocessor->($self, $chunk_text);
    push @{$self->{sections}{$ns}{$basename}}, ['text', $processed_chunk];
}

sub _handle_error {
    my ($self, $type, $details) = @_;
    my $handler = $self->cfg__get_prefixed('Fab/callbacks')->{error_handler};
    $handler->($self, $type, $details);
}

# --- Primitive API (the stable interface for parsers) ---

sub out__target_section { my ($self, $basename, $namespace) = @_; $namespace //= $self->{current_target}->[0]; $self->{current_target} = [$namespace, $basename]; $self->{sections}{$namespace}{$basename} //= []; }
sub out__embed { my ($self, $basename, $namespace, $options) = @_; my ($target_ns, $target_basename) = @{$self->{current_target}}; $namespace //= $target_ns; push @{$self->{sections}{$target_ns}{$target_basename}}, ['embed', $namespace, $basename, $options]; }
sub cfg__set { my ($self, $key, $value) = @_; $self->{config}{$key} = $value; }
sub cfg__append { my ($self, $key, @values) = @_; if ($self->{config}{'Fab/list_keys'}{$key}) { push @{$self->{config}{$key}}, @values; } else { $self->{config}{$key} .= join('', @values); } }
sub cfg__get { my ($self, $key) = @_; return $self->{config}{$key}; }
sub cfg__get_prefixed { my ($self, $key) = @_; for my $prefix (reverse @{$self->{config}{'Fab/call_stack_prefixes'}}) { my $full_key = $prefix . $key; return $self->{config}{$full_key} if exists $self->{config}{$full_key}; } return $self->{config}{$key}; }
sub group__start { my ($self, $flavor) = @_; push @{$self->{group_stack}}, { config => dclone($self->{config}) }; }
sub group__end { my ($self, $flavor) = @_; my $snapshot = pop @{$self->{group_stack}} or die; $self->{config} = $snapshot->{config};}
sub cfg__pop {
    my ($self, $key, @args) = @_;
    my $type = $self->_get_key_type($key);

    if ($type eq 'list') {
        die "cfg__pop on a list key accepts at most one argument (a count)" if @args > 1;
        my $count = @args ? $args[0] : 1;
        my $list = $self->{config}{$key} or return;
        die "cfg__pop expected array reference for key '$key'" unless ref $list eq 'ARRAY';
        die "cfg__pop cannot pop $count elements from list of size " . scalar(@$list) if $count > @$list;
        my @popped = splice @$list, -$count;
        return wantarray ? @popped : $popped[-1];
    }
    elsif ($type eq 'hash') {
        # Silently a no-op if no keys are provided.
        return wantarray ? () : undef unless @args;
        my @keys_to_delete = @args;
        my $hash = $self->{config}{$key} or return;
        die "cfg__pop expected hash reference for key '$key'" unless ref $hash eq 'HASH';
        my @deleted_values = delete @{$hash}{@keys_to_delete};
        return wantarray ? @deleted_values : $deleted_values[0];
    }
    else {
        # This branch handles scalars. A pop on a scalar is only valid with no args.
        die "cfg__pop with arguments can only be called on list or hash keys" if @args;
        die "cfg__pop called on non-list/non-hash key '$key'";
    }
}
sub cfg__prepend_elt {
    my ($self, $key, $offset, $value) = @_;
    my $type = $self->_get_key_type($key);

    if ($type eq 'list') {
        $self->{config}{$key} //= [];
        my $list = $self->{config}{$key};
        die "cfg__prepend_elt expected array reference for key '$key'" unless ref $list eq 'ARRAY';
        splice @$list, $offset, 0, $value;
        return;
    }
    elsif ($type eq 'hash') {
        die "cfg__prepend_elt on hash requires value to be an array reference of a [key, value] pair"
            unless ref $value eq 'ARRAY' && @$value == 2;
        $self->{config}{$key} //= {};
        my $hash = $self->{config}{$key};
        die "cfg__prepend_elt expected hash reference for key '$key'" unless ref $hash eq 'HASH';
        $hash->{$value->[0]} = $value->[1];
        return;
    }
    else {
        die "cfg__prepend_elt called on non-list/non-hash key '$key'";
    }
}
sub cfg__get_joined {
    my ($self, $key, $joiners, $options) = @_;
    die "cfg__get_joined requires an array reference for joiners"
        unless ref $joiners eq 'ARRAY';
    my $type = $self->_get_key_type($key);

    if ($type eq 'list') {
        my $list = $self->{config}{$key} or return '';
        die "cfg__get_joined expected array reference for key '$key'" unless ref $list eq 'ARRAY';
        return $self->_join_list($list, $joiners, $options);
    }
    elsif ($type eq 'hash') {
       my $hash = $self->{config}{$key} or return '';
       my @sorted_keys = $self->_get_sorted_hash_keys($key);
       my $intra_pair_joiner = $joiners->[0];
       my @inter_pair_joiners = @$joiners > 1 ? @$joiners[1..$#$joiners] : ($#$joiners == 0 ? [$joiners->[0]] : []);
       my @joined_pairs = map { $_ . $intra_pair_joiner . $hash->{$_} } @sorted_keys;
       return $self->_join_list(\@joined_pairs, \@inter_pair_joiners, $options);
    }
    else {
        die "cfg__get_joined called on non-list/non-hash key '$key'";
    }
}
sub out__get_joined {
    my ($self, $spec, $joiners, $options) = @_;
    die "out__get_joined requires an array reference for joiners"
        unless ref $joiners eq 'ARRAY';
    my ($ns, $basename) = split /:/, $spec;
    my $all_chunks = $self->{sections}{$ns}{$basename} or return '';
    my @text_parts = map { $_->[1] } grep { $_->[0] eq 'text' } @$all_chunks;
    return $self->_join_list(\@text_parts, $joiners, $options);
}

# --- Private Helpers ---
sub _get_key_type {
    my ($self, $key) = @_;
    return 'hash' if $self->{config}{'Fab/hash_keys'}{$key};
    return 'list' if $self->{config}{'Fab/list_keys'}{$key};
    return 'scalar';
}
sub _get_sorted_hash_keys {
    my ($self, $key) = @_;
    my $hash = $self->{config}{$key} or return ();
    die "_get_sorted_hash_keys expected hash reference for key '$key'" unless ref $hash eq 'HASH';
    my $sorter = $self->{config}{'Fab/hash_key_sort_order'};
    return sort { $sorter->($a, $b) } (keys %$hash);
}
sub _hash_to_sorted_list {
    my ($self, $key) = @_;
    my $hash = $self->{config}{$key} or return [];
    my @sorted_keys = $self->_get_sorted_hash_keys($key);
    return [ map { $_, $hash->{$_} } @sorted_keys ];
}
sub _join_list {
    my ($self, $list, $joiners, $options) = @_;
    $options //= {};
    my $num_elements = scalar @$list;
    return '' unless $num_elements;
    return $list->[0] if $num_elements == 1;

    my $num_joiners_to_use = $num_elements - 1;
    if (my $mod = $options->{permitted_joiners_modulo}) {
        die "Join operation violates permitted_joiners_modulo rule (want multiple of $mod, got $num_joiners_to_use)"
            if $num_joiners_to_use % $mod != 0;
    }

    my $output = $list->[0];
    for my $i (1 .. $num_joiners_to_use) {
        $output .= $joiners->[($i - 1) % @$joiners] . $list->[$i];
    }
    return $output;
}

# --- Assembly Phase ---

sub assemble {
    my ($self, $root_spec) = @_;
    my ($ns, $basename) = split /:/, $root_spec;
    my $output = $self->_expand_section($ns, $basename, {});
    chomp($output); # Trim final trailing newline.
#    $output =~ s/\s+$//;	# Maybe better (but what for?!) ???
    return $output;
}

sub _expand_section {
    my ($self, $ns, $basename, $seen) = @_;
    my $id = "$ns:$basename";
    die "Circular dependency for section '$id'" if $seen->{$id};
    local $seen->{$id} = 1;

    my $chunks = $self->_resolve_section($ns, $basename);
    return "" unless $chunks;

    my $output = "";
    for my $chunk (@$chunks) {
        my ($type, @data) = @$chunk;
        if ($type eq 'text') {
            $output .= $data[0];
        } elsif ($type eq 'embed') {
            $output .= $self->_expand_section($data[0], $data[1], $seen);
        }
    }
    return $output;
}

sub _resolve_section {
    my ($self, $ns, $basename) = @_;
    return $self->{sections}{$ns}{$basename}
        if exists $self->{sections}{$ns} && exists $self->{sections}{$ns}{$basename};

    my $parents_key = "Fab/inheritance_graph/$ns/parents";
    # FIX: Correctly dereference the array reference of parents.
    for my $parent_ns (@{$self->{config}{$parents_key} || []}) {
        my $chunks = $self->_resolve_section($parent_ns, $basename);
        return $chunks if $chunks;
    }
    return undef;
}

1;

__END__