File Coverage

blib/lib/Perl6/Form.pm

Criterion	Covered	Total	%
statement	458	951	48.1
branch	158	542	29.1
condition	89	332	26.8
subroutine	52	96	54.1
pod	0	57	0.0
total	757	1978	38.2

package Perl6::Form;
use 5.008;

our $VERSION = '0.090';

use Perl6::Export;
use Scalar::Util qw( readonly );
use List::Util   qw( max min first );
use Carp;
use charnames ':full';

my %caller_opts;

sub fatal {
    croak @_, "\nin call to &form";
}

sub defined_or_space {
    return " " if !defined $_[0] || length $_[0] == 0;
    return $_[0];
}

sub boolean {
    return $_[0] ? 1 : 0;
}

sub pattern {
    return $_[0] if ref $_[0] eq 'Regexp';
    return $_[0] ? qr/(?=)/ : qr/(?!)/;
}

sub code {
    my ($newval, $name ) = @_;
    my $type = ref($newval) || "'$newval'";
    fatal "Value for '$name' option must be code reference (not $type)"
            unless $type eq 'CODE';
    return $newval;
}

my %std_one = (
    '=' => '{=[{1}[=}',
    '_' => '{_[{1}[_}',
);

sub one_char {
    my ($newval, undef, $opts ) = @_;
    $newval = [ $newval ] unless ref $newval eq 'ARRAY';
    for (@$newval) {
        fatal "Value for 'single' option must be single character (not '$_')"
            if length() != 1;
        $opts->{field} =
            user_def([qr/\Q$_\E/, $std_one{$_}||'{[{1}[}'], 'single', $opts);
    }
    return;
}

sub layout_word {
    fatal "Value for layout option must be 'across', 'down', 'balanced', ",
          "or 'tabular\n(not '$_[0]')"
            unless $_[0] =~ /^(across|down|balanced|tabular)$/;
    return $_[0];
}

sub pos_integer {
    fatal "Value for '$_[1]' option must be positive integer (not $_[0])"
            unless int($_[0]) eq $_[0] && $_[0] > 0;
    return $_[0];
}

sub strings_or_undef {
    my ($val, $name) = @_;
    my $type = ref $val;
    if (!defined $val) { $val = [] }
    elsif (!$type)     { $val = [ "$val" ] }
    fatal "Value for '$name' option must be string, array of strings, or undef (not \L$type\E)"
            unless ref $val eq 'ARRAY';
    return $val;
}

my $unlimited = ~0>>1;          # Ersatz infinity

sub height_vals {
    my ($vals) = @_;
    my $type = ref $vals;
    if (!defined $vals)      { $vals = {min=>0,     max=>$unlimited} }
    elsif (!$type && $vals eq 'minimal')
                             { $vals = {min=>0, max=>$unlimited, minimal=>1} }
    elsif (!$type)           { $vals = {min=>$vals, max=>$vals}     }
    elsif ($type eq 'HASH')  { $vals->{min}||=0;
                               defined $vals->{max} or $vals->{max}=$unlimited;
                             }
    fatal "Values for height option must be positive integers (not $_[0])"
                unless ref $vals eq 'HASH'
                    && !grep {int($vals->{$_}) ne $vals->{$_}} qw(min max);
    return $vals;
}

my %nothing = map {$_=>sub{""}} qw(first even odd other);

sub std_body {
    my ($rows, $fill, $opt) = @_;
    join("", @$rows, @$fill);
}
my %std_body = (other =>\&std_body);

my %def_page = (
    length => $unlimited,
    width  => 78,
    header => \%nothing,        # Args: ($opts)
    footer => \%nothing,        # Args: ($opts)
    body   => \%std_body,       # Args: ($body_rows, $body_len, $opts)
    feed   => \%nothing,        # Args: ($opts)
    number => undef,
);

sub form_body {
    my ($format) = @_;
    $format = '{[{*}[}' unless defined $format;
    return sub {
        my ($rows, $fill, $opt) = @_;
        my %form_opts = ( page=>{width => $opt->{page}{width}} );
        @{$form_opts{height}}{qw(min max)} = (@$rows+@$fill) x 2
            unless $opt->{page}{length} == $unlimited;
        return form(\%form_opts, $format, $rows);
    }
}

sub hashify {
    my ($what, $val, $default_undef, $default_val) = @_;
    if (!defined $val) {
        return { other => $default_undef};
    }
    if (!ref $val) {
        return { other => $default_val->($val) };
    }
    if (ref $val eq 'CODE') {
        return { other => $val };
    }
    if (ref $val eq 'HASH') {
        fatal "Invalid key for $what: '$_'"
            for grep { !/^(first|last|even|odd|other)$/ } keys %$val;
        my %hash;
        for (keys %$val) {
            if (!ref $val->{$_}) {
                $hash{$_} = $default_val->($val->{$_})
            }
            elsif (ref $val->{$_} ne 'CODE') {
                fatal "Value for $what '$_' must be string or subroutine";
            }
            else {
                $hash{$_} = $val->{$_};
            }
        }
        return \%hash;
    }
    fatal "Value for $what must be string, subroutine, or hash";
}

sub page_hash {
    my ($h, undef, $opts) = @_;
    fatal "Value for 'page' option must be hash reference (not $_)"
        for grep $_ ne 'HASH', ref $h;
    $h = { %{$opts->{page}}, %$h };
    fatal "Unknown page sub-option ('$_')"
        for grep {!exists $def_page{$_}} keys %$h;
    fatal "Page $_ must be greater than zero"
        for grep $h->{$_} <= 0, qw(length width);
    $h->{body} =
        hashify("body preprocessor", $h->{body}, \&std_body, \&form_body);
    for (qw( header footer feed )) {
        $h->{$_} = hashify($_, $h->{$_}, sub{""}, sub{my($str)=@_; sub{$str}});
    }
    return $h;
}

sub filehandle {
    fatal "Value for 'out' option must be filehandle (not '$_')"
            for grep {$_ ne 'GLOB' } ref $_[0];
    return $_[0];
}

sub user_def {
    my ($spec, $name, $opts) = @_;
    my $type = ref $spec;
    fatal "Value of 'field' option must be an array of pairs or a hash (not ",
          $type||"'$spec'", ")"
                unless $type =~ /^(ARRAY|HASH)$/;
    if ($type eq 'ARRAY') {
        fatal "Missing value for last user-defined field ('$spec->[-1]')"
            if @$spec % 2;
    }
    else {
        $spec = [%$spec];
    }
    my @from = @{$opts->{field}{from}||=[]};
    my @to   = @{$opts->{field}{to}||=[]};
    my $count = @from;
    for (my $i=0; $i<@$spec; $i+=2, $count++) {
        my ($pat, $fld) = @{$spec}[$i,$i+1];
        push @from, "$pat(?{$count})";
        push @to,   (ref $fld eq 'CODE' ? $fld : sub{$fld});
    }
    return {from=>\@from, to=>\@to};
}

my %std_opt = (
    out     => { set => \&filehandle,       def => \*STDOUT,            },
    ws      => { set => \&pattern,          def => undef,               },
    fill    => { set => \&defined_or_space, def => " ",                 },
    lfill   => { set => \&defined_or_space, def => undef,               },
    rfill   => { set => \&defined_or_space, def => undef,               },
    hfill   => { set => \&defined_or_space, def => undef,               },
    tfill   => { set => \&defined_or_space, def => undef,               },
    bfill   => { set => \&defined_or_space, def => undef,               },
    vfill   => { set => \&defined_or_space, def => undef,               },
    single  => { set => \&one_char,         def => undef,               },
    field   => { set => \&user_def,         def => {from=>[],to=>[]}    },
    bullet  => { set => \&strings_or_undef, def => []                   },
    height  => { set => \&height_vals,      def => {min=>0, max=>$unlimited} },
    layout  => { set => \&layout_word,      def => 'balanced',          },
    break   => { set => \&code,             def => break_at('-'),       },
    page    => { set => \&page_hash,        def => {%def_page},         },
    under   => { set => sub {"$_[0]"},      def => undef                },
    interleave  => { set => \&boolean,      def => 0                    },
    untrimmed   => { set => \&boolean,      def => 0,                   },
    locale      => { set => \&boolean,      def => 0,                   },
);

my %def_opts = map {$_=>$std_opt{$_}{def}}  keys %std_opt;

sub get_locale_vals {   # args: $dec_mark, $thou_sep, $thou_group
    use POSIX;
    $lconv = POSIX::localeconv();
    $_[0] = exists $lconv->{decimal_point} ? $lconv->{decimal_point} : "?";
    $_[1] = exists $lconv->{thousands_sep} ? $lconv->{thousands_sep} : "";
    $_[2] = exists $lconv->{grouping} ? [unpack "c*", $lconv->{grouping}] : [0];
}

my %std_literal = (
    break   => \&break_lit,
    literal => 1,
    vjust   => \&jverlit,
    hjust   => \&jhorlit,
);

sub update(\%\%;$) {
    my ($old, $new, $croak) = @_;
    my @bad;
    for my $opt (keys %$new) {
        my $std = $std_opt{$opt};
        push @bad, "Unknown option: $opt=>'$new->{$opt}" and next unless $std;
        $old->{$opt} = $std->{set}->($new->{$opt}, $opt, $old);
    }
    if (@bad && $croak) { croak join "\n", @bad }
    elsif (@bad)        { fatal join "\n", @bad }
}



# Horizontal justifiers

sub fillpat {
    my ($pos, $fill, $len) = @_;
    return "" if $len < 0;
    return substr($fill x max(0,($pos+$len)/length($fill)+1), $pos, $len);
}

sub jhorlit {}  # literals don't need any justification

sub jverbatim {
    jleft(@_, precropped=>1);
}

sub jleft {
    my (undef, %val) = @_;
    $_[0] =~ s/^\s+// unless $val{precropped};
    my $len = length $_[0];
    $_[0] .= fillpat($val{pos}+$len, $val{post}, $val{width}-$len);
    substr($_[0],$val{width}) = "" unless $val{stretch};
 }

 sub jright {
    my (undef, %val) = @_;
    $_[0] =~ s/\s+$// unless $val{precropped};
    $_[0] = fillpat($val{pos}, $val{pre}, $val{width}-length($_[0])) . $_[0];
    substr($_[0],0,-$val{width}) = "" unless $val{stretch};
 }

 sub jcentre {
    my (undef, %val) = @_;
    $_[0] =~ s/^\s+|\s+$//g;
    $val{precropped} = 1;
    my $indent = int( ($val{width}-length $_[0])/2 );
    jleft($_[0], %val, stretch=>0, pos=>$val{pos}+$indent, width=>$val{width}-$indent);
    jright($_[0], %val);
 }

 sub jfull {
    my ($str, %val) = @_;
    my $rem = $val{width};
    $str =~ s/^\s+|\s+$//g;
    unless ($val{last}) {
        my $rem = $val{width}-length($str);
        $str = reverse $str;
        1 while $rem>0 && $str =~ s/( +)/($rem-->0?" ":"").$1/ge;
        $_[0] = reverse $str;
    }
    &jleft;
 }

 sub jsingle {
    my (undef, %val) = @_;
    $_[0] = length $_[0] ? substr($_[0],0,1) : fillpat($val{pos}, $val{pre},1);
 }

 sub jfatal {
    die "Internal error in &form."
 }

 sub joverflow (\%\%) {
    $_[0]{overflow} = 1;
    %{$_[1]} = ();
    return \&jfatal;
 }

 sub jbullet {
    return ($_[0],1);
 }

 sub jnum {
    my ($fld,$precurr,$incurr,$postcurr,$width,$opts,$setplaces,$checkplaces)
        = @_;
    my $orig = $fld;
    $incurr ||= qr/(?!)/;

    my $comma_count  = $fld=~tr/,//;
    my $period_count = $fld=~tr/.//;
    my $apost_count  = $fld=~tr/ '//;
    my $integral = $comma_count > 1  && !($period_count || $apost_count)
                || $period_count > 1 && !($comma_count  || $apost_count)
                || $apost_count > 1  && !($comma_count  || $period_count);
    my ($whole, $point, $places) =
        $integral ? ($fld, "", "")
                  : ($fld =~ /^([]{>,.' 0]*)([.,]|\Q$incurr\E)([[}<0]*)/g);

    my $missing = $width-length($fld);
    if ($missing>0) { $fld = substr($fld,0,1) x $missing . $fld }

    $opts->{lfill} = '0' if $whole  =~ m/^0+/;
    $opts->{rfill} = '0' if $places =~ m/0+$/;
    my $comma = $whole =~ /([,.' ])/ ? $1 : '';
    my $grouping;
    if ($comma) {
        $grouping = $whole =~ /,(?:\]{2},\]{3}|>{2},>{3})\z/ ? [3,2] # Subcont
                  : $whole =~ /[,.' ](\]+|>+)\z/             ? [length($1)]
                  :                                            undef;
    }
    if (defined $setplaces) {
        $places = $setplaces;
        $whole = $width - length($point) - $setplaces;
    }
    else {
        $_ = length for $whole, $places;
    }
    fatal "Inconsistent number of decimal places in numeric field.\n",
          "Specified as $checkplaces but found $places"
                if $checkplaces && $places != $checkplaces;
    my $huh = substr( ('?'x$whole).$point.('?'x$places), 0, $width);
    my $duh = substr( ('#'x$whole).$point.('#'x$places), 0, $width);

    $places -= length($postcurr);

    get_locale_vals($point, $comma, $grouping) if $opts->{locale};

    return sub {
        my ($orig, %val) = @_;
        $_[0] = " "x$val{width} and return if $orig =~ /^\s*$/;
        $orig =~ s/,|\Q$incurr\E/./ if $point ne '.';
        my ($pre,$post) = ($precurr,$postcurr);
        if ($orig !~ /^\s*-/ || $orig == -$orig) {
            $pre  =~ s/^[(-]|[(-]$/ /g;
            $post =~ s/^[)-]|[)-]$/ /g;
        }
        my ($fail, $str);
        my ($w, $p);
        if ($integral) {
            local $SIG{__WARN__} = sub { $fail = 1 };
            $str = sprintf('%*d',$val{width},int($orig));
            ($w,$p) = ($str =~ /^\s*(.*)$/,"");          # integer
        }
        else {
            local $SIG{__WARN__} = sub { $fail = 1 };
            $str = sprintf('%*.*f',$val{width},$places,$orig);
            ($w,$p) = ($str =~ /^\s*(.*)\.(.*)$/g);      # floating point
        }
        if ($fail) {
            $_[0] = $huh;
        }
        else {
            if ($grouping) {
                my @groups = @$grouping;
                my $group = shift @groups;
                if ($group) {
                    $w =~ s/(\d)(\d{$group})\z/$1$comma$2/;
                    do {
                        $group = shift @groups if @groups;
                    } while $group && $w =~ s/(?
                }
            }
            if (length($w) > $width || !$val{stretch} && ($w ? length($w) : 0)+length($pre) > $whole) {
                $_[0] = $duh;
            }
            else {
                $str = $integral ? $w : $w.q(.).$p;
                $str =~ s/(\.\d+?)(0+)$/$1/
                    unless $orig =~ /\.\d\{$places,\}[1-9]/;
                if ($integral && $str < 0) {
                    if ($pre =~ /[(]/ || $post =~ /[)]/) {
                        $str =~ s/-//;
                    }
                    else {
                        s/-/ / for $pre, $post;
                    }
                }
                $str =~ s/^(?:\Q$pre\E)?/$pre/;
                if ($val{pre} =~ /^0+$/) {
                    $str =~ s{^((\D*)(\d.*))\.}
                             {$2 . ("0"  x max(0,$whole-length $1)) . "$3."}e;
                    $val{pre} = " ";
                }
                my $postlen = length($post);
                if (!$integral) {
                    $str =~ s/^(.*)\./$1$point/;
                    my $width = $val{width}-$whole+length($1);
                    jleft($str,  %val, width=>$width, precropped=>1);
                    jright($str, %val, precropped=>1);
                }
                if ($integral) {
                    $str = substr((q{ } x max(0,$width)) . $str . $post, -$width);
                    $str =~ s/(?:[ ]{$postlen}([ ]*))$/$post$+/;
                }
                elsif ($postlen) {
                    $str =~ s/(?:[ ]{$postlen}([ ]*)|.{$postlen}())$/$post$+/;
                }
                $_[0] = $str;
            }
        }
    }
 }


# Vertical justifiers

sub jverlit {
    my ($height, $above, $below, $column) = @_;
    push @$column, ($column->[0]||"") while @$column < $height;
}

sub jmiddle {
    my ($height, $above, $below, $column) = @_;
    my $add = int(($height-@$column)/2);
    splice @$column, 0, 0, ($above)x$add;
    $add = $height-@$column;
    push @$column, ($below)x$add;
}

sub jbottom {
    my ($height, $above, $below, $column) = @_;
    my $pre = $height-@$column;
    splice @$column, 0, 0, ($above)x$pre;
}

sub jtop {
    my ($height, $above, $below, $column) = @_;
    my $post = $height-@$column;
    push @$column, ($below)x$post;
}


my $precurrpat  = qr/^(\{)    ([^]0>[<,']+?)  ([]>,'0])/x;
my $incurrpat   = qr/([]>0])  ([^]0>[<,'. ]+?) ([[<0])  /x;
my $postcurrpat = qr/([[<>0]) ([^]0>[<]+)     (\}$)     /x;

sub perl6_match {
    my ($str, $pat) = @_;
    use re 'eval';
    if (my @vals = $str =~ /$pat/) {
        unshift @vals, $&;
        bless \@vals, 'Perl6::Form::Rule::Okay';
    }
    else {
        bless [], 'Perl6::Form::Rule::Fail';
    }
}

my $litval;
sub litval {
    ($litval) = @_ if @_;
    return $litval;
}

my ($fld, $udnum);
sub fldvals {
    ($fld, $udnum) = @_ if @_;
    return ($fld, $udnum);
}

our $nestedbraces = qr/ \{ (?: (?> ((?!\{|\}).)+ ) | (??{ $nestedbraces }) )* \} /sx;

sub segment ($\@\%$\%) {
    my ($format, $args, $opts, $fldcnt, $argcache) = @_;
    my $width =
        defined $opts->{page}{width} ? $opts->{page}{width} : length($format);
    my $userdef = join("|", @{$opts->{field}{from}}) || qr/(?!)/;
    my $bullet  = join("|", map quotemeta, @{$opts->{bullet}}) || qr/(?!)/;
    use re 'eval';
    my @format;
    while ($format =~ /\G ((?>(?:\\.|(?!$userdef|$bullet|\{).)*))
                                                         (?{litval($^N)})
                          (?: ($userdef)                 (?{fldvals($^N,$^R)})
                            | ($bullet)                  (?{fldvals($^N,-1)})
                            | ($nestedbraces)            (?{fldvals($^N,undef)})
                          )
                      /gcsx) {
        push @format, litval(), fldvals();
    }
    push @format, substr ($format, pos($format)||0);
    my $args_req = int(@format/3);
    my (@formatters,@starred,@vstarred);
    for my $i (0..$args_req) {
        my ($literal,$field,$userdef) = @format[3*$i..3*$i+2];
        $literal =~ s/\\\{/{/g;
        push @formatters, { %std_literal,
                            width => length($literal),
                            src   => \$literal,
                          };
        $width -= length($literal);
        if (defined $field) {
            my %form;
            my %fldopts = %$opts;
            $fldcnt++;
            my ($setwidth, $setplaces, $checkwidth, $checkplaces);
            if (defined $userdef) {
                if ($userdef < 0) {
                    $form{isbullet} = \"$field";
                }
                else {
                    my ($from,$to) =
                        map $_->[$userdef], @{$opts->{field}}{'from','to'};
                    $field = $to->(perl6_match($field,$from),\%fldopts);
                }
            }
            my $fld = $field;
            my ($precurr, $incurr, $postcurr) = ("")x3;
            $form{width} = length $field;
            if ($form{isbullet}) {
                $form{vjust} = \&jtop;
                $form{hjust} = \&jbullet;
                $form{break} = \&break_bullet;
                $form{src}   = [];
                ($form{bullethole} = $field) =~ s/./ /gs;
            }
            else {
                $form{stretch} = !$form{isbullet} && $fld =~ s/[+]//;
                @form{qw(verbatim break hjust)}
                    = (1, \&break_verbatim, \&jverbatim)
                        if $fld =~ /["']/ && $fld !~ /[][><]/;
                        # was: if $fld =~ /["']/ && $fld !~ /[][]/;
                $form{trackpos} = $fld =~ s/(\{):|:(\})/$+/g;
                $form{vjust} = $fld =~ s/=//g ? \&jmiddle
                             : $fld =~ s/_//g ? \&jbottom
                             :                  \&jtop
                             ;

                ($checkwidth, $extras) = $fld =~ m/\(\s*(\d+[.,]?\d*)\s*\)/g;
                fatal "Too many width specifications in $field" if $extras;
                if ($checkwidth) {
                    $checkplaces = $checkwidth =~ s/[.,](\d+)// && $1;
                    for ($fld) {
                        s{([][>
                         { $1 . ($1 x length $2) }xe and last;
                        s{(\(\s*\d+[.,]?\d*\s*\)) ([][>
                         { ($2 x length $1) . $2 }xe and last;
                        s{(> [.,]) (\(\s*\d+[.,]?\d*\s*\))}
                         { $1 . ('<' x length $2) }xe and last;
                        s{(\(\s*\d+[.,]?\d*\s*\)) ([.,] <)}
                         { ('>' x length $1) . $2 }xe and last;
                        s{(\(\s*\d+[.,]?\d*\s*\)) ([.,] \[)}
                         { (']' x length $1) . $2 }xe and last;
                        s{(\(\s*\d+[.,]?\d*\s*\))}
                         { '[' x length $1 }xe and last;
                    }
                }

                ($setwidth, $extras) = $fld =~ m/\{\s*(\d+[.,]?\d*|\*)\s*\}/g
                                   and $fld =~ s/\{\s*(\d+[.,]?\d*|\*)\s*\}//;
                fatal "Too many width specifications in $field"
                    if $extras || $setwidth && $checkwidth;
                if ($setwidth && $setwidth =~ s/[.,](\d+)//) {
                    $setplaces = $1 || 0;
                }

                for ([$checkwidth, $checkplaces], [$setwidth, $setplaces]) {
                    fatal "Can't fit $_->[1] decimal place",($_->[1]!=1?'s':''),
                          " in a $_->[0]-character field"
                              if defined($_->[0]) && defined($_->[1])
                              && $_->[0] ne '*'
                              && $_->[0] <= $_->[1];
                }

                $precurr =
                    $fld =~ s/$precurrpat/$1.($3 x length $2).$3/e  ? "$2" : "";
                $incurr =
                    $fld =~ m/$incurrpat/                           ? "$2" : "";
                $postcurr =
                    $fld =~ s/$postcurrpat/$1.($1 x length $2).$3/e ? "$2" : "";

                if ($form{width} == 2) {
                    $fld = '[[';
                }
                elsif ($form{width} == 3) {
                    $fld =~ s/^ \{ ([.,]) \} $/].[/x;
                    $fld =~ s/^ \{ (.)    \} $/$+$+$+/x;
                }
                elsif ($form{width} > 3)  {
                    $fld =~ s/^ \{ ([]>,]+ ([]>])) \} $/$2$2$1/x;   # Integral comma'd field
                    $fld =~ s/^ \{ ([.,] \[)   /]$1/x;
                    $fld =~ s/^ \{ ([.,] \<)   />$1/x;
                    $fld =~ s/(\] .* [.,]) \} $/$1\[/x;
                    $fld =~ s/(\> .* [.,]) \} $/$1
                    $fld =~ s/^ \{ (.) | (.) \} $/$+$+/gx;
                }

                $form{width} = $setwidth
                    if defined $setwidth && $setwidth ne '*';

                if ($form{width} == 2) {
                    $fld = substr($fld,0,1) x 2;
                }
                elsif ($form{width} == 3) {
                    $fld =~ s/^ \{ ([.,]) \} $/].[/x;
                    $fld =~ s/^ \{ (.)    \} $/$+$+$+/x;
                }
                elsif ($form{width} > 3)  {
                    $fld =~ s/^ \{ ([.,] \[)   /]$1/x;
                    $fld =~ s/^ \{ ([.,] \<)   />$1/x;
                    $fld =~ s/(\] .* [.,]) \} $/$1\[/x;
                    $fld =~ s/(\> .* [.,]) \} $/$1
                    $fld =~ s/^ \{ (.) | (.) \} $/$+$+/gx;
                }

                $form{width} = $setwidth
                    if defined $setwidth && $setwidth ne '*';
            }

            if ($setwidth && $setwidth eq '*')  {
                push @{$form{verbatim} ? \@vstarred : \@starred}, \%form;
            }
            else {
                $width -= $form{width}
            }

            $form{line} = 1 unless $form{isbullet} || $fld =~ /[][IV"]/;

            $form{hjust} ||= $form{width} == 1                   ? \&jsingle
                           : ($fld =~ /^(?:<+|\[+)$/)            ? \&jleft
                           : ($fld =~ /^(?:>+|\]+)$/)            ? \&jright
                           : ($fld =~ /^(?:I+|\|+|>+<+|\]+\[+)$/)? \&jcentre
                           : ($fld =~ /^(?:<+>+|\[+\]+)$/)       ? \&jfull
                           : ($fld =~ /^(?:V+)$/)                ? joverflow(%form, %fldopts)
                           : ($fld =~ /^(?: [>,' 0]*  \.          [<0]*
                                          | [],' 0]*  \.          [[0]*
                                          | [>.' 0]*  \,          [<0]*
                                          | [].' 0]*  \,          [[0]*
                                          | [>.,' 0]* \Q$incurr\E [<0]*
                                          | [].,' 0]* \Q$incurr\E [[0]*
                                          | [].' 0]*  \,          [[0]*
                                        )$/x)                       ? do {
                                      $form{break}=\&break_nl;
                                      jnum($fld,$precurr,$incurr,$postcurr,
                                           $form{width},\%fldopts,
                                           $setplaces, $checkplaces)
                                                                        }
                           : fatal "Field $fldcnt is of unknown type: $field"
                           ;

            $form{break}=\&break_nl if $form{stretch};

            fatal "Inconsistent width for field $fldcnt.\n",
                  "Specified as '$field' but actual width is $form{width}"
                if defined $checkwidth && $form{width} != $checkwidth;

            splice @$args, $i, 0, "" if $form{isbullet}; # BEFORE ANY OPTIONS

            while (ref $args->[$i] eq 'HASH') {
                update %fldopts, %{splice @$args, $i, 1};
            }
            $form{opts} = \%fldopts;

            splice @$args, $i, 0, "" if $form{overflow}; # AFTER ANY OPTIONS

            fatal "Missing data value for field ", $i, " ($field)"
                unless defined $args->[$i];

            for ($args->[$i]) {
                next if $form{isbullet};
                $form{src} ||=
                    ref eq 'ARRAY' ? do {
                            my $s = join "", map { my $val = $_; $val =~ s/\n(?!\z)/\r/g; $val }
                                             map {!defined() ? "\n"
                                                 : /\n\z/    ? $_
                                                 :             "$_\n"}  @$_;
                            $form{trackpos} ? ($argcache->{$_} ||= \$s) : \$s;
                            }
                  : (readonly $_ || !$form{trackpos}) ? \(my$s=$_)
                  : \$_;
            }

            $form{break} ||= $fldopts{break} || $opts->{break};

            push @formatters, \%form;
        }
    }
    splice @$args, 0, $args_req;
    $_[-1] = $fldcnt;   # remember field count
    # Distribute {*} widths...
    for my $f (@vstarred) {
        $f->{maxwidth} = max 0, map {length} split "\n", ${$f->{src}};
    }
    if (@starred||@vstarred) {
        my $fldwidth = int($width/(@starred+@vstarred));
        for my $f (@vstarred) {
            $f->{width} = @starred ? $f->{maxwidth}
                                   : min $fldwidth, $f->{maxwidth};
            $width += $fldwidth - $f->{width};
        }
        $fldwidth = int($width/(@starred+@vstarred)) if @starred;
        $_->{width} = $fldwidth for @starred;
    }

    # Attach bullets to neighbouring fields,
    # and compute offsets from left margin...
    my $offset = 0;
    my $lastbullet;
    for my $f (@formatters) {
        $f->{pos} = $offset;
        $offset += $f->{width};
        if ($lastbullet) {
            if ($f->{literal}) {  # IGNORE IT
            }
            elsif ($f->{isbullet}) {
                my $literal = ${$lastbullet->{isbullet}};
                %$lastbullet = (%std_literal, width=>length($literal), src=>\$literal);
                $lastbullet = undef;
            }
            else {
                $f->{hasbullet} = $lastbullet;
                $lastbullet = undef;
            }
        }
        $lastbullet = $f if $f->{isbullet};
    }
    if ($lastbullet) {
        my $literal = ${$lastbullet->{isbullet}};
        %$lastbullet = (%std_literal, width=>length($literal), src=>\$literal);
    }

    return \@formatters;
}

sub layout_groups {
    my @groups;
    my $i = 0;
    FORMATTER: for my $f (@_) {
        $f->{index} = $i++;
        for my $group (@groups) {
            if ($f->{src} == $group->[0]{src}) {
                push @$group, $f;
                next FORMATTER;
            }
        }
        push @groups, [$f];
    }
    return @groups;
}

sub make_col {
    my ($f, $opts, $maxheight, $tabular) = @_;
    $maxheight = min $unlimited,
                     grep defined(), $maxheight, $f->{opts}{height}{max};
    my ($str_ref, $width) = @{$f}{qw(src width)};
    my @col;
    my ($more, $text) = (1,"");
    my $bullet = $f->{hasbullet};
    $bullet->{bullets} = [] if $bullet;
    my $bulleted = 1;
    until ($f->{done}) {
        my $skipped = 0;
        unless ($f->{isbullet} || $f->{width} == 1 || $f->{verbatim}) {
            ($skipped) = ($$str_ref =~ /\G(\s*)/gc);
            if ($skipped||=0) {
                $bulleted = ($skipped =~ /\n/);
                $skipped=~s/\r\Z//;
                $skipped = ($skipped=~tr/\r//);
                push @col, ("") x $skipped;
                last if $tabular && $bulleted && @col;
            }
        }
        my $prev_pos = pos(${$str_ref}) // -1;
        ($text,$more,$eol) = $f->{break}->($str_ref,$width,$f->{opts}{ws});
        if ($text eq q{} && $more && (pos(${$str_ref})//-1) == $prev_pos) {
            $text = substr(${$str_ref}, pos(${$str_ref}), 1);
            pos(${$str_ref})++;
            $more = pos(${$str_ref}) < length(${$str_ref});
        }
        if ($f->{opts}{ws}) {
            $text =~ s{($f->{opts}{ws})}
                      { @caps = grep { defined $$_ } 2..$#+;
                        @caps = length($1) ? " " : "" unless @caps;
                        join "", @caps;
                      }ge;
        }
        $text .= "\r" if $eol;
        push @col, $text;
        if ($bullet && $text =~ /\S/) {
            push @{$bullet->{bullets}}, ($bullet->{bullethole}) x $skipped;
            push @{$bullet->{bullets}}, $bulleted ? ${$bullet->{isbullet}}
                                                  : $bullet->{bullethole};
        }
        $f->{done} = 1
            if defined $f->{opts}{height}{max} && @col==$f->{opts}{height}{max};
        last if !$more || @col==$maxheight;
        $f->{done} = 1 if $f->{line};
        $bulleted = 0;
    }
    @col = () if @col == 1 && $col[0] eq "";
    $_[3] = $more && !$f->{done} if @_>3;
    return \@col;
}

my $count = 0;

sub balance_cols {
    my ($group, $opts, $maxheight) = @_;
    my ($first, $src) = ($group->[0], $group->[0]{src});
    if (@$group<=1) {
        $first->{formcol} = make_col($first,$opts,$maxheight);
        return;
    }
    my $pos = pos($$src) || 0;
    my $minheight = 0;
    while (1) {
        my @cols;
        pos($$src) = $pos;
        my $medheight = int(($maxheight+$minheight+1)/2);
        for my $f (@$group) {
            $f->{done} = 0;
            push @cols, make_col($f,$opts,$medheight)
        }
        if ($maxheight <= $minheight+1) {
            for (0..$#cols) {
                $group->[$_]{formcol} = $cols[$_];
            }
            return;
        }
        (substr($$src,pos$$src) =~ /\S/) ? $minheight : $maxheight = $medheight;
    }
}

sub delineate_overflows {
    for my $formats (@_) {
        # Is there a block field on the line?
        next if grep { !(  $_->{line}
                        || $_->{literal}
                        || $_->{notlastoverflow}
                        )
                     } @$formats;
        for (@$formats) {
            next unless $_->{overflow};
            if ($_->{notlastoverflow}) {
                $_->{line} = 1;
            }
        }
    }
    for my $formats (@_) {
        for (@$formats) {
            next if !$_->{overflow} || $_->{notlastoverflow};
            $_->{opts}{height}{max} = $unlimited;
            $_->{opts}{height}{minimal} = 0;
        }
    }
}

sub resolve_overflows {
    my ($formatters,$prevformatters) = @_;
    FORMATTER: for my $fld (@$formatters) {
        next unless $fld->{overflow};
        my $left  = $fld->{pos};
        my $right = $left + $fld->{width} - 1;
        my $overflowed;
        for my $prev (@$prevformatters) {
            next if $prev->{literal};
            my $prevleft  = $prev->{pos};
            my $prevright = $prevleft + $prev->{width} - 1;
            if ($right >= $prevleft && $left <= $prevright) { # overlap
                if ($overflowed) {
                    $prev->{notlastoverflow} = 1
                        if $prev->{overflow} && $prev->{src} == $fld->{src};
                    next;
                }
                my %newfld = ( %$prev, opts=>{}, overflow=>1 );
                my @keep = qw( width pos complete done line );
                @newfld{@keep} = @{$fld}{@keep};
                update %{$newfld{opts}}, %{$fld->{opts}};
                $newfld{opts}{height} = {min=>0, max=>undef, minimal=>1};
                $fld = \%newfld;
                $prev->{notlastoverflow} = 1 if $prev->{overflow};
                $overflowed = 1;
            }
        }
        croak "Useless overflow field (no field above it)"
            unless $overflowed;
    }
}

sub make_cols($$\@\%$) {
    my ($formatters,$prevformatters,$parts, $opts, $maxheight) = @_;
    my (@bullets, @max, @min);
    for my $f (@$formatters) {
        if    ($f->{isbullet})              { push @bullets, $f }
        elsif ($f->{opts}{height}{minimal}) { push @min, $f }
        else                                { push @max, $f }
    }
    my @maxgroups = layout_groups(@max);
    my @mingroups = layout_groups(@min);
    my $has_nonminimal = grep {!$_->{literal} && !$_->{line}} @max;
    if ($opts->{layout} eq 'balanced') { # balanced column-by-column
        for my $g (@maxgroups) {
            balance_cols($g,$opts, $maxheight);
        }
        $maxheight = map 0+@{$_->{formcol}||[]}, @$formatters
            if grep {!$_->{literal} && !$_->{opts}{height}{minimal}} @$formatters;
        for my $g (@mingroups) {
            balance_cols($g, $opts, $maxheight);
        }
        for my $f (@$formatters) {
            push @$parts, $f->{formcol}||$f->{bullets}||[];
        }
    }
    elsif ($opts->{layout} eq 'down') { # column-by-column
        for my $col (0..$#$formatters) {
            my $f = $formatters->[$col];
            next if $f->{isbullet} || $f->{opts}{height}{minimal};
            $parts->[$col] = make_col($f,$opts, $maxheight);
        }
        $maxheight = min $maxheight,
                         max map { defined() ? scalar @$_ : 0 } @$parts
            if $has_nonminimal;
        for my $col (0..$#$formatters) {
            my $f = $formatters->[$col];
            next if $f->{isbullet} || !$f->{opts}{height}{minimal};
            $parts->[$col] = make_col($f,$opts, $maxheight);
        }
        for my $col (0..$#$formatters) {
            my $f = $formatters->[$col];
            next unless $f->{isbullet};
            $parts->[$col] = $f->{bullets}||[];
        }
    }
    elsif ($opts->{layout} eq 'across') { # across row-by-row
        my %incomplete = (first=>1);
        for (my $row=0;$row<$maxheight && grep {$_} values %incomplete;$row++) {
            %incomplete = ();
            for my $col (0..$#$formatters) {
                $parts->[$col] ||= [];
            }
            for my $col (0..$#$formatters) {
                my $f = $formatters->[$col];
                next if $f->{isbullet} || $f->{opts}{height}{minimal};
                next if $f->{line} && $row>0 || $f->{done};
                my ($str_ref, $width) = @{$f}{qw(src width)};
                $$str_ref =~ /\G\s+/gc unless $f->{verbatim};
                ($parts->[$col][$row], my $more) =
                        $f->{break}->($str_ref,$width,$f->{opts}{ws});
                $parts->[$col][$row] =~ s/$f->{opts}{ws}/ /g if $f->{opts}{ws};
                $f->{done} = 1 if !$f->{literal}
                           && $row+1 >= ($f->{opts}{height}{max}||$maxheight);
                $incomplete{$str_ref} = $more
                    unless $f->{literal} || $f->{line} || $f->{done};
            }
            for my $col (0..$#$formatters) {
                my $f = $formatters->[$col];
                next if $f->{isbullet} || !$f->{opts}{height}{minimal};
                next if $f->{line} && $row>0 || $f->{done};
                my ($str_ref, $width) = @{$f}{qw(src width)};
                $$str_ref =~ /\G\s+/gc unless $f->{verbatim};
                ($parts->[$col][$row], my $more) =
                        $f->{break}->($str_ref,$width,$f->{opts}{ws});
                $parts->[$col][$row] =~ s/$f->{opts}{ws}/ /g if $f->{opts}{ws};
                $f->{done} = 1 if !$f->{literal}
                           && $row+1 >= ($f->{opts}{height}{max}||$maxheight);
                $incomplete{$str_ref} = $more
                    unless $has_nonminimal || $f->{done};
            }
            for my $col (0..$#$formatters) {
                my $f = $formatters->[$col];
                next unless $f->{isbullet};
                $parts->[$col][$row] = shift @{$f->{bullets}};
            }
        }
    }
    else { # tabular layout: down to the first \n, then across, then fill
        my $finished = 0;
        for my $col (0..$#$formatters) { $parts->[$col] = []; }
        while (!$finished) {
            $finished = 1;
            for my $col (0..$#$formatters) {
                my $tabular_more = 1;
                my $f = $formatters->[$col];
                next if $f->{isbullet} || $f->{opts}{height}{minimal};
                push @{$parts->[$col]},
                     @{make_col($f,$opts, $maxheight, $tabular_more)};
                $finished &&= !$tabular_more;
            }
            my $minimaxheight = min $maxheight,
                             max map { defined() ? scalar @$_ : 0 } @$parts
                if $has_nonminimal;
            for my $col (0..$#$formatters) {
                my $tabular = 1;
                my $f = $formatters->[$col];
                next if $f->{isbullet} || !$f->{opts}{height}{minimal};
                push @{$parts->[$col]},
                     @{make_col($f,$opts, $maxheight, $tabular)};
            }
            for my $col (0..$#$formatters-1) {
                my $f = $formatters->[$col];
                if ($f->{isbullet}) {
                    push @{$parts->[$col]}, @{$f->{bullets}||[]};
                    push @{$parts->[$col]},
                         ($f->{bullethole})x($minimaxheight-@{$parts->[$col]});
                }
                elsif ($f->{literal}) {
                    push @{$parts->[$col]},
                         (${$f->{src}})x($minimaxheight-@{$parts->[$col]});
                }
                else {
                    push @{$parts->[$col]},
                         ("")x($minimaxheight-@{$parts->[$col]});
                }
            }
            $maxheight -= $minimaxheight||0;
        }
    }
    for my $g (@maxgroups, @mingroups) {
        my $text = $g->[-1]{src};
        next if substr($$text,pos($$text)||0) =~ /\S/;
        for (1..@$g) {
            next unless @{$parts->[$g->[-$_]{index}]};
            $g->[-$_]{final} = 1;
            last;
        }
    }
    for my $i (1..@$parts) {
        $formatters->[-$i]{complete} = 0
    }
    for my $f (grep {!($_->{literal}||$_->{line})} @$formatters) {
        next if $f->{done} || $f->{isbullet} || $f->{opts}{height}{minimal};
        return 1 if substr(${$f->{src}},pos(${$f->{src}})||0) =~ /\S/;
    }
    return 0;
}

sub make_underline {
    my ($under, $prevline, $nextline) = @_;
    $under =~ s/(\n*)\z//;
    my $trail = "$1"|"\n";
    for my $l ($nextline, $prevline) {
        $l = join "", map {$_->{literal} ? ${$_->{src}} : '*'x$_->{width} } @$l;
        $l =~ s{(.)}{$1 =~ /\s/ ? "\0" : "\1"}ges;
    }
    $nextline |= $prevline;
    $nextline =~ s{\0}{ }g;
    $nextline =~ s{(\cA+)}{my $len=length($1); substr($under x $len,0,$len)}ge;
    $nextline .= $trail;
    return [{ %std_literal, width => length($nextline), src => \$nextline }];
}

sub linecount($) {
    return tr/\n// + (/[^\n]\z/?1:0) for @_;
}

use warnings::register;

sub form is export(:MANDATORY) {
    croak "Useless call to &form in void context" unless defined wantarray;

    # Handle formatting calls...
    my ($package, $file, $line) = caller;
    my $caller_opts = $caller_opts{$package,$file} ||= {};
    if (keys %$caller_opts) {
        $line = first { $_ < $line } sort {$b<=>$a} keys %$caller_opts;
        $caller_opts = $caller_opts->{$line} || {}
                if defined $line;
    }
    my %opts = (%def_opts, %$caller_opts);
    my $fldcnt = 0;
    my @section = {opts=>{%opts}, text=>[]};
    my $formats = \@_;
    my $first = 1;
    my %argcache;
    my ($prevformat,$currformat,@allformats);
    while (@$formats) {
        my $format = shift @$formats;
        if (ref $format eq 'HASH') {
            update %opts, %$format;
            $opts{page}{number} = undef unless defined $format->{page}{number};
            push @section, {opts=>{%opts}};
            redo;
        }
        if ($first) {   # Change format lists if data first or last
            if ($opts{interleave}) {
                $formats = [$format =~ /.*(?:\n|\z)/g];
                $format = shift @$formats;
            }
            $first = 0;
        }
        $format =~ s/\n?\z/\n/;
        $prevformat = $currformat;
        $currformat = segment($format, @_, %opts, $fldcnt, %argcache);
        resolve_overflows($currformat, $prevformat);
        if (defined $opts{under}) {
            push @{$section[-1]{formatters}},
                make_underline($opts{under}, $prevformat, $currformat);
            $opts{under} = undef;
        }
        push @{$section[-1]{formatters}}, $currformat;
        push @allformats, $currformat;
    }
    croak scalar(@_), " too many data values after last format" if @_;
    delineate_overflows(@allformats);

    my $text = "";
    my $pagetype = 'first';
    my $pagenum = 1;
    for my $section (@section) {
        next unless $section->{formatters};
        my $sect_opts = $section->{opts};
        my $page = $sect_opts->{page};
        $page->{number} = $pagenum unless defined $page->{number};
        my $pagelen = $page->{length};
        while (1) {
            my $parity = $page->{number}%2 ? 'odd' : 'even';
            my $header =
             $page->{header}{$pagetype} ? $page->{header}{$pagetype}($sect_opts)
             : $page->{header}{$parity} ? $page->{header}{$parity}($sect_opts)
             : $page->{header}{other}   ? $page->{header}{other}($sect_opts)
             : "";
            my $footer =
             $page->{footer}{$pagetype} ? $page->{footer}{$pagetype}($sect_opts)
             : $page->{footer}{$parity} ? $page->{footer}{$parity}($sect_opts)
             : $page->{footer}{other}   ? $page->{footer}{other}($sect_opts)
             : "";
            my $feed =
             $page->{feed}{$pagetype} ? $page->{feed}{$pagetype}($sect_opts)
             : $page->{feed}{$parity} ? $page->{feed}{$parity}($sect_opts)
             : $page->{feed}{other}   ? $page->{feed}{other}($sect_opts)
             : "";
            length and s/\n?\z/\n/ for $header, $footer;  # NOT for $feed
            my $bodyfn = $page->{body}{$pagetype}
                      || $page->{body}{$parity}
                      || $page->{body}{other}
                      || \&std_body;
            my $bodylen = max 1, $pagelen - linecount($header) - linecount($footer);
            my ($pagetext, $more) = make_page($section, $sect_opts, $bodylen);
            if (!$more && $section == $section[-1]) {
                my $lastheader =
                    $page->{header}{last} ? $page->{header}{last}($sect_opts)
                                          : $header;
                my $lastfooter =
                    $page->{footer}{last} ? $page->{footer}{last}($sect_opts)
                                          : $footer;
                length and s/\n?\z/\n/ for $lastheader, $lastfooter;
                my $lastlen = max 1, $pagelen-linecount($lastheader)-linecount($lastfooter);
                if (@$pagetext <= $lastlen) {
                    $pagetype = 'last';
                    ($header, $footer, $bodylen)
                        = ($lastheader, $lastfooter, $lastlen);
                    $feed = $page->{feed}{last}($sect_opts)
                        if $page->{feed}{last};
                    $bodyfn = $page->{body}{last}
                        if $page->{body}{last};
                }
            }
            my $fill = $pagelen < $unlimited ? [("\n") x max(0,$bodylen-@$pagetext)]
                                             : [];

            my $body = $bodyfn->($pagetext, $fill, \%opts);

            $text .= $header . $body . $footer . $feed;
            $page->{number}++;

            # Handle special case of empty last page...
            last unless $more || $section == $section[-1] && $pagetype ne 'last';
            $pagetype = $page->{number}%2 ? 'odd' : 'even';
        }
        $pagenum = $page->{number};
    }

    $text =~ s/[^\S\n]+\n/\n/g unless $opts{untrimmed};
    return $text;
}

sub make_page {
        my ($section, $sect_opts, $bodylen) = @_;
        my (@text, $more);
        my ($prevformatters, $formatters);
        while (@text < $bodylen && @{$section->{formatters}}) {
            $prevformatters = $formatters;
            $formatters = $section->{formatters}[0];
            $more = make_cols($formatters,$prevformatters,my @parts, %$sect_opts, $bodylen-@text);
            shift @{$section->{formatters}} unless $more;
            my $maxheight = 0;
            my $maxwidth = 0;
            for my $col (0..$#parts) {
                local $_ = $parts[$col];
                pop @$_ while @$_ && ! length($_->[-1]);
                $maxheight = max($maxheight, scalar(@$_), $formatters->[$col]{opts}{height}{min}||0);
                # $formatters->[$col]{pos} = $maxwidth;
                # $maxwidth += $formatters->[$col]{width};
            }
            for my $col (0..$#parts) {
                my $f = $formatters->[$col];
                push @{$parts[$col]}, ("") x max(0,($f->{height}{min}||0)-@{$parts[$col]});
                my $fopts = $f->{opts};
                my $tfill = first {defined $_} @{$fopts}{qw(tfill vfill fill)}, " ";
                my $bfill = first {defined $_} @{$fopts}{qw(bfill vfill fill)}, " ";
                my $lfill = first {defined $_} @{$fopts}{qw(lfill hfill fill)}, " ";
                my $rfill = first {defined $_} @{$fopts}{qw(rfill hfill fill)}, " ";
                $f->{vjust}->($maxheight,$tfill,$bfill,$parts[$col]);
                for my $row (0..$#{$parts[$col]}) {
                    my $last = $parts[$col][$row] =~ s/\r//;
                    $f->{hjust}->($parts[$col][$row], pre=>$lfill, post=>$rfill,
                                  last=>$last, pos=>$f->{pos},
                                  stretch=>$f->{stretch}, width=>$f->{width},
                                 );
                }
            }
            for my $row (0..$maxheight) {
                push @text, join "",
                    grep { defined } map $parts[$_][$row],0..$#parts;
            }
        }
        return (\@text, $more);
}

# Extract perpendicular cross-sections from an AoA, AoH, HoA, HoH, AoHoA, etc.

sub section {
    my ($structure, @index) = @_;
    $structure = [ values %$structure ] if ref $structure eq 'HASH';
    my @section;
    for my $row ( @$structure ) {
        local $,=",";
        my $type = ref $row or croak "Too many indices (starting with [@index])";
        if ($type eq 'HASH') {
            @index = keys %$row unless @index;
            push @{$section[$_]}, $row->{$index[$_]} for 0..$#index;
        }
        elsif ($type eq 'ARRAY') {
            @index = (0..$#$row) unless @index;
            push @{$section[$_]}, $row->[$index[$_]] for 0..$#index;
        }
        else {
            my $what = ref $structure;
            croak "Can't drill ", ($what ? lc $what : $structure) , " of $type";
        }
    }
    return @section;
}

sub slice {
    my ($structure, @indices) = @_;
    return ref eq 'HASH' ? @{$_}{@indices} : @{$_}[@indices] for $structure;
}

sub vals { return ref eq 'HASH' ? values %$_ : @$_ for $_[0] }

sub drill (\[@%];@) is export {
    my ($structure, @indices) = @_;
    return $structure unless @indices;
    my $index = shift @indices;
    my @section = [ @$index ? slice($structure,@$index) : vals($structure) ];
    return @section unless @indices;
    for my $index (@indices) {
        @section = map {section $_, @$index} @section;
    }
    return @section;
}

sub break_lit {
    return (${$_[0]},0,0);
}

sub break_bullet {
    my ($src) = @_;
    my $next = pop @$src || "";
    return ($next,@$src>0,0);
}

sub break_verbatim {
    my ($str,$rem) = @_;
    $$str =~ m/ \G ([^\n\r]*) (?:\r|\n|\z) /gcx or return ("",0);
    return (substr("$1",0,$rem), $$str =~ m/ \G (?=.) /sgcx ? 1 : 0,0);
}

sub break_nl {
    my ($str) = @_;
    if ($$str =~ m/\G [^\S\n\r]* ([^\n\r]*?) [^\S\r\n]* (?:\r|$)/gcxm)  {
        return ("$1", $$str =~ /\G(?=.*\S)/sgc?1:0, 1);
    }
    else {
        return ("",0,0);
    }
}

my $wsnzw = q{ (??{length($^N)?'(?=)':'(?!)'}) };

sub break_at is export {
    my ($hyphen) = @_;
    my ($lit_hy) = qr/\Q$hyphen\E/;
    my $hylen = length($hyphen);
    my @ret;
    return sub {
        my ($str,$rem,$ws) = @_;
        my ($last_breakable, $res) = ($rem+1,"", 0);
        for ($$str) {
            use re 'eval';
            while ($rem > 0 && (pos()||0) < length()) {
                if ($ws && /\G ($ws) $wsnzw/gcx) {
                    my $captured;
                    if ($#+ > 1) {      # may be extra captures...
                        for (2..$#+) {
                            next unless defined $$_;
                            $captured++;
                            $res .= $$_;
                            $rem -= length $$_;
                        }
                    }
                    unless ($captured) {
                        $res .= $1;
                        $rem--;
                    }
                    $last_breakable = length $res;
                }
                elsif ($rem>=$hylen && /\G $lit_hy /gcx) {
                    $res .= $hyphen;
                    $rem -= $hylen;
                    $last_breakable = length $res;
                }
                elsif (/\G ((?!$lit_hy)[^\n\r]) /gcx) {
                    $res .= $1;
                    $rem--;
                    $last_breakable = length $res if $res =~ /\s$/;
                }
                else { last }
            }
            my $reslen = length $res;
            $ws ||= qr/\s/;
            unless (/\G (?=$lit_hy|($ws)$wsnzw|\z|\n|\r) /gcx) {
                if ($last_breakable <= $reslen) {
                    pos() -= $reslen-$last_breakable;
                    substr($res,$last_breakable) = "";
                }
                elsif ($reslen > $hylen) {
                    if ($res =~ /\S\S\S{$hylen}$/) {
                        pos() -= $hylen;
                        substr($res,-$hylen) = $hyphen;
                    }
                    elsif ($res =~ s/(\S+)$//) {
                        pos() -= length($1);
                    }
                }
            }
            my $rem = substr($$str, pos $$str);
            return ($res, $rem=~/\S/?1:0, $rem =~ /^\s*(?:\z|\n|\r)/);
        }
    };
}

sub import {
    my $class = shift;
    my ($package, $file, $line) = caller;
    my %opts;
    for (@_) {
        croak "Options for $class must be specified in a hash"
            unless ref eq 'HASH';
        update(%opts, %$_, 'croak');
    }
    $caller_opts{$package,$file}{$line} = \%opts;
}

package Perl6::Form::Rule::Fail;
use overload
    '""'   => sub{ undef },
    '0+'   => sub{ undef },
    'bool' => sub{ 0 },
;

package Perl6::Form::Rule::Okay;
use overload
    '""'   => sub{ $_[0][0] },
    '0+'   => sub{ $_[0][0] },
    'bool' => sub{ 1 },
;

1;
__END__