File Coverage

blib/lib/PerlX/QuoteOperator.pm

Criterion	Covered	Total	%
statement	61	61	100.0
branch	15	18	83.3
condition	6	9	66.6
subroutine	11	11	100.0
pod	1	1	100.0
total	94	100	94.0

package PerlX::QuoteOperator;
use strict;
use warnings;
use 5.008001;

use Devel::Declare ();
use Text::Balanced ();
use base 'Devel::Declare::Context::Simple';

our $VERSION = '0.07';
our $qtype   = __PACKAGE__ . '::qtype';
our $parser  = __PACKAGE__ . '::parser';
our $debug   = __PACKAGE__ . '::debug';

sub import {
    my ($self, $name, $param, $caller) = @_;

    # not importing unless name & parameters provided (TBD... check these)
    return unless $name && $param;

    # called directly and not via a PerlX::QuoteOperator::* module
    unless ($caller) {
        $caller = caller;
        $self   = __PACKAGE__->new;
    }

    # quote like operator to emulate.  Default is qq// unless -emulate is provided
    $self->{ $qtype } = $param->{ -emulate } || 'qq';

    # invoke my heath robinson parser or not?
    # (not using parser means just insert quote operator and leave to Perl)
    $self->{ $parser } = $param->{ -parser } || 0;

    # debug or not to debug... that is the question
    $self->{ $debug } = $param->{ -debug } || 0;

    # Create D::D trigger for $name in calling program
    Devel::Declare->setup_for(
        $caller, {
            $name => { const => sub { $self->parser(@_) } },
        },
    );

    no strict 'refs';
    *{$caller.'::'.$name} = $param->{ -with };
}

sub parser {
    my $self = shift;
    $self->init(@_);
    $self->skip_declarator;          # skip past "http"
    $self->skipspace;

    my $line = $self->get_linestr;   # get me current line of code

    if ( $self->{ $parser } ) {
        # find start & end of quote operator
        my $pos    = $self->offset;        # position just after "http"
        my $opener = substr( $line, $pos, 1 );
        my $closer = _closing_delim( $opener );
        if ($closer eq $opener) {
            do { $pos++ } until substr( $line, $pos, 1 ) eq $closer;
        }
        else {
            my $text = substr($line, $pos);
            my ($capture, $remaining) = Text::Balanced::extract_bracketed($text, $opener);
            $pos += length $capture;
            $pos--;
        }

        # and wrap sub() around quote operator (needed for lists)
        substr( $line, $pos + 1, 0 )      = ')';
        substr( $line, $self->offset, 0 ) = '(' . $self->{ $qtype };

    }
    else {
        # Can rely on Perl parser for everything.. just insert quote-like operator
        substr( $line, $self->offset, 0 ) = q{ } . $self->{ $qtype };
    }

    # eg: qURL(http://www.foo.com/baz) => qURL qq(http://www.foo.com/baz)
    # pass back to parser
    $self->set_linestr( $line );
    warn "$line\n" if $self->{ $debug };

    return;
}

sub _closing_delim {
    my $d = shift;
    return ')' if $d eq '(';
    return '}' if $d eq '{';
    return ']' if $d eq '[';
    return '>' if $d eq '<';
    return $d;
}

1;


__END__