First stab at String::Formatter::Tagged

format-tagged.pl

#!/usr/bin/env perl
use strict;
use warnings;
use 5.020;

package String::Formatter::Tagged {
    use parent 'String::Formatter';
    use String::Tagged;
    use Safe::Isa;

    # new customisable function: how to join formatted hunks
    sub default_hunk_joiner { 'join_with_format' }
    sub hunk_joiner { $_[0]->{hunk_joiner} }

    # these are used in join_with_format to correctly map literal
    # hunks to the original string: hunk_simply (and others) convert
    # %% to %, and if we didn't revert that conversion, we'd get the
    # wrong alignment
    sub default_special_literals { return +{
        '%' => '%%',
    }};

    sub new {
        my ($class,$arg) = @_;
        my $self = $class->SUPER::new($arg);
        my $hunk_joiner = $arg->{hunk_joiner} || $self->default_hunk_joiner;
        $self->{hunk_joiner} = $self->can($hunk_joiner) unless ref $hunk_joiner;
        # if true, the hunker gets a String::Tagged instance, instead
        # of a plain string
        $self->{hunker_wants_tagged_string} = $arg->{hunker_wants_tagged_string} // 0;
        $self->{special_literals} = $arg->{special_literals} || $self->default_special_literals;
        return $self;
    }

    # this is copied from String::Formatter
    sub format {
        my $self   = shift;
        my $format = shift;

        Carp::croak("not enough arguments for stringf-based format")
              unless defined $format;
        Carp::croak("format is not a String::Tagged instance")
              unless $format->$_isa('String::Tagged');

        my $hunker = $self->format_hunker;
        # new: normally pass a plain string (for compatibility), allow
        # passing a String::Tagged
        my $hunks  = $self->$hunker(
            $self->{hunker_wants_tagged_string}
                ? $format
                : $format->str,
        );

        my $processor = $self->input_processor;
        my $input = $self->$processor([ @_ ]);

        my $replacer = $self->string_replacer;
        $self->$replacer($hunks, $input);

        my $formatter = $self->hunk_formatter;
        # new: keep replacements (strings) separate from hunks (mixed
        # strings and hashrefs)
        my @replacements = @$hunks;
        ref($_) and $_ = $self->$formatter($_) for @replacements;

        # new: use the joiner
        my $joiner = $self->hunk_joiner;
        my $string = $self->$joiner($format,$hunks,\@replacements);
        return $string;
    }

    # this is what String::Formatter normally does
    sub join_no_format {
        my ($self,$format,$hunks,$replacements) = @_;
        return join '',@$replacements;
    }

    # this is the special joiner that deals with ::Tagged
    sub join_with_format {
        my ($self,$format,$hunks,$replacements) = @_;

        my $result = $format->clone;
        my $pos = 0;
        # this might be better written as C<pairs zip
        # @$hunks,@$replacements> ?
        for my $hunk_idx (0..$#$hunks) {
            my $current_hunk = $hunks->[$hunk_idx];
            my $current_replacement = $replacements->[$hunk_idx];

            if (ref $current_hunk) {
                # this is a non-literal hunk: replace its literal in
                # the format string with its replacement
                my $length = length($current_hunk->{literal});
                $result->set_substr(
                    $pos,
                    $length,
                    $current_replacement,
                );
                $pos += $length;
            }
            else {
                # this is a literal hunk: adjust for %% and the like,
                # then just advance the $pos
                $current_hunk = $self->{special_literals}->{$current_hunk}
                    || $current_hunk;
                my $length = length($current_hunk);
                $pos += $length;
            }
        }

        return $result;
    }
};

use Term::ANSIColor;

sub show_colored_string {
    my ($str) = @_;
    $str->iter_substr_nooverlap(
        sub {
            my ($substr,%tags) = @_;
            if (my $c = $tags{color}) {
                print color($c);
            }
            print $substr;
            print color('reset');
        },
    );
    print "\n";
}

my $str = String::Tagged->new('a-%{foo}s-test');
$str->apply_tag(-1,1, color=>'red');
$str->apply_tag(10,-1, color=>'green');
$str->apply_tag(1,9, color=>'yellow');
show_colored_string($str);

my $manual = $str->clone;
$manual->set_substr(2,7,'manual');
show_colored_string($manual);

my $formatter = String::Formatter::Tagged->new({
    input_processor => 'require_named_input',
    string_replacer => 'named_replace',
    codes => { s => sub { $_ } },
});

my $result = $formatter->format($str,{foo=>'something'});
show_colored_string($result);