Filter::QuasiQuote - Quasiquoting for Perl

    package MyFilter;

    require Filter::QuasiQuote;
    our @ISA = qw( Filter::QuasiQuote );

    sub my_filter {
        my ($self, $s, $file, $line, $col) = @_;
        # parse the dsl source in $s and emit the perl source in ONE LINE
        return generate_perl_source( parse_dsl( $s ) );
    }

    # and in another file:
    use MyFilter;

    [:my_filter|This is my little DSL...|]

    use Filter::QuasiQuote; # BAD!!!
    use base 'Filter::QuasiQuote'; # BAD TOO!!!

package Filter::QuasiQuote;

use strict;
no warnings;
#use Smart::Comments;

our $VERSION = '0.07';

use Filter::Util::Call qw(filter_read);

our $Debug;

sub import {
    my ($type, @arguments) = @_ ;
    #warn $type;
    my ($package, $filename, $line) = caller;
    #warn "$package";
    my $self = bless {
        file => $filename,
        line => $line,
        quoted => undef,
        method => undef,
        ignore_once => undef,
        pos_diff => 0,
    }, $type;
    Filter::Util::Call::real_import($self, $package, 0) ;
}

sub filter {
    my ($self) = @_ ;
    #warn "SELF: $self";
    my($status) ;

    $status = filter_read;
    #warn scalar(s/\r//g);
    #warn "Last char: ", ord(substr($_, -1, 1));
    my $changed;
    if ($status > 0) {
        $self->{pos_diff} = 0;
        $self->{line}++;
        my ($i, $buf);
        while (1) {
            $i++;
            $self->debug("Pos ", pos, ", Pass $i, Line $self->{line}");
            if (/\G\s+/gc) { $buf .= $& }
            if (/\G\[:(\w+)\|(.*?)\|\]/gc) {
                #warn "$1 => $2";
                my ($meth, $s) = ($1, $2);
                my $len = length($&);
                my $to = pos;

                if (defined $self->{method}) {
                    die "Syntax error at $self->{file}, line $self->{line}: Quasiquotes cannot be nested.\n";
                }

                #warn "to: $to\n";
                #warn "len: $len\n";
                if ($self->can($meth)) {
                    #warn "POS diff: $self->{pos_diff}";
                    my $col = $to - $self->{pos_diff} - $len + 1;
                    my $res = $self->$meth($s, $self->{file}, $self->{line}, $col);
                    #$self->debug("Pos BEFORE change \$_: ", pos($_));
                    substr($_, $to - $len, $len, $res);
                    $changed = 1; pos($_) = $to - $len + length($res);
                    $self->{pos_diff} = length($res) - $len;
                    #$self->debug("Pos AFTER change \$_: ", pos($_));
                    ### $_
                }
            }
            elsif (/\G\[:(\w+)\|(.*)/gc) {
                my ($meth, $s) = ($1, $2);
                my $len = length($&);
                my $to = pos $_;
                #warn "len: $len to: $to match: $&\n";
                if (!$self->can($meth)) {
                    $self->debug("Ignoring starting $meth at $self->{line} (pos $to, pass $i)");
                    $self->{ignore_once} = 1;
                    #$self->{method} = $meth;
                    last;
                }

                substr($_, $to - $len, $len, ' ');
                $changed = 1;
                my $col = $to - $self->{pos_diff} - $len + 1;
                $self->{saved_pos} = [$self->{line}, $col];
                ### $_

                if (!defined $self->{method}) {
                    $self->{quoted} = $s;
                    $self->{method} = $meth;
                } else {
                    die "Syntax error at $self->{file}, line $self->{line}: Quasiquotes cannot be nested.\n";
                }
                last;
            }
            elsif (/\G\|\]/gc) {
                my $s = $buf;
                my $len = length($buf . $&);
                my $to = pos;
                $self->debug("Found closing tag: ", ref $self, " (pos $to, pass $i, line $self->{line})");
                if ($self->{ignore_once}) {
                    $self->debug("Ignoring closing $self->{method} at $self->{line} (pos $to, pass $i)") if $self->{method};
                    undef $self->{ignore_once};
                    undef $self->{method};
                    undef $self->{quoted};
                    next;
                }

                my $meth = $self->{method};
                if (!defined $meth) {
                    #warn $self;
                    #warn "POS: ", pos;
                    die ref $self, ": Syntax error at $self->{file}, line $self->{line}: Pending closing quasiquote. (pos $to, pass $i)\n";
                }
                #warn "POS diff: $self->{pos_diff}";
                my $pos = $self->{saved_pos};
                my ($line, $col);
                if (!$pos) { $line = $self->{line}; $col = 0 }
                else { ($line, $col) = @$pos }
                my $res = $self->$meth($self->{quoted} . $s, $self->{file}, $line, $col);
                undef $self->{method};
                undef $self->{quoted};
                substr($_, $to - $len, $len, $res);
                $changed = 1; pos($_) = $to - $len + length($res);
                $self->{pos_diff} = length($res) - $len;

                #$changed = 1;
            }
            elsif (/\G[^\|\[]+|\G./gc) {
                #print "Ignored: $_";
                #last;
                #warn $&;
                $buf .= $&;
            }
            else {
                last;
            }
        }
        if (!$changed && defined $self->{method}) {
            $self->{quoted} .= $_;
            $_ = "\n"; $changed = 1;
        }
        #warn "$self->{file}: line $self->{line}: $_";
    }
    $self->debug("Processed: (line $self->{line}): $_") if $changed;
    s/\n//gs;
    $_ .= "\n" unless substr($_, -1, 1) eq "\n";
    #warn $status;
    $status ;
}

sub debug {
    my $self = shift;
    warn ref $self, ": ", join('', @_), "\n" if $Debug;
}

1;
__END__