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


line stmt bran cond sub pod time code
1             package PerlX::QuoteOperator;
2 5     5   75215 use strict;
  5         7  
  5         150  
3 5     5   20 use warnings;
  5         32  
  5         107  
4 5     5   84 use 5.008001;
  5         14  
  5         124  
5              
6 5     5   88036 use Devel::Declare ();
  5         633868  
  5         96  
7 5     5   57509 use Text::Balanced ();
  5         99839  
  5         117  
8 5     5   28 use base 'Devel::Declare::Context::Simple';
  5         7  
  5         1992  
9              
10             our $VERSION = '0.08';
11             our $qtype = __PACKAGE__ . '::qtype';
12             our $parser = __PACKAGE__ . '::parser';
13             our $debug = __PACKAGE__ . '::debug';
14              
15             sub import {
16 10     10   380 my ($self, $name, $param, $caller) = @_;
17            
18             # not importing unless name & parameters provided (TBD... check these)
19 10 100 66     84 return unless $name && $param;
20            
21             # called directly and not via a PerlX::QuoteOperator::* module
22 9 50       18 unless ($caller) {
23 9         11 $caller = caller;
24 9         33 $self = __PACKAGE__->new;
25             }
26            
27             # quote like operator to emulate. Default is qq// unless -emulate is provided
28 9   50     67 $self->{ $qtype } = $param->{ -emulate } || 'qq';
29            
30             # invoke my heath robinson parser or not?
31             # (not using parser means just insert quote operator and leave to Perl)
32 9   100     27 $self->{ $parser } = $param->{ -parser } || 0;
33            
34             # debug or not to debug... that is the question
35 9   50     25 $self->{ $debug } = $param->{ -debug } || 0;
36              
37             # Create D::D trigger for $name in calling program
38             Devel::Declare->setup_for(
39             $caller, {
40 16     16   318 $name => { const => sub { $self->parser(@_) } },
41             },
42 9         55 );
43            
44 5     5   48119 no strict 'refs';
  5         8  
  5         1231  
45 9         160 *{$caller.'::'.$name} = $param->{ -with };
  9         242  
46             }
47              
48             sub parser {
49 16     16 1 12 my $self = shift;
50 16         41 $self->init(@_);
51 16         87 $self->skip_declarator; # skip past "http"
52 16         255 $self->skipspace;
53              
54 16         80 my $line = $self->get_linestr; # get me current line of code
55              
56 16 100       59 if ( $self->{ $parser } ) {
57             # find start & end of quote operator
58 5         8 my $pos = $self->offset; # position just after "http"
59 5         13 my $opener = substr( $line, $pos, 1 );
60 5         8 my $closer = _closing_delim( $opener );
61 5 100       7 if ($closer eq $opener) {
62 2         2 do { $pos++ } until substr( $line, $pos, 1 ) eq $closer;
  24         30  
63             }
64             else {
65 3         5 my $text = substr($line, $pos);
66 3         7 my ($capture, $remaining) = Text::Balanced::extract_bracketed($text, $opener);
67 3         420 $pos += length $capture;
68 3         3 $pos--;
69             }
70            
71             # and wrap sub() around quote operator (needed for lists)
72 5         7 substr( $line, $pos + 1, 0 ) = ')';
73 5         14 substr( $line, $self->offset, 0 ) = '(' . $self->{ $qtype };
74            
75             }
76             else {
77             # Can rely on Perl parser for everything.. just insert quote-like operator
78 11         28 substr( $line, $self->offset, 0 ) = q{ } . $self->{ $qtype };
79             }
80              
81             # eg: qURL(http://www.foo.com/baz) => qURL qq(http://www.foo.com/baz)
82             # pass back to parser
83 16         59 $self->set_linestr( $line );
84 16 50       66 warn "$line\n" if $self->{ $debug };
85              
86 16         78 return;
87             }
88              
89             sub _closing_delim {
90 5     5   5 my $d = shift;
91 5 100       10 return ')' if $d eq '(';
92 4 100       11 return '}' if $d eq '{';
93 3 100       7 return ']' if $d eq '[';
94 2 50       6 return '>' if $d eq '<';
95 2         2 return $d;
96             }
97              
98             1;
99              
100              
101             __END__