—

              
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.08';
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__
HideShow 314 lines of Pod
=head1 NAME
PerlX::QuoteOperator - Create new quote-like operators in Perl
=head1 VERSION
Version 0.08
=head1 SYNOPSIS
Create a quote-like operator which convert text to uppercase:
    use PerlX::QuoteOperator quc => {
        -emulate => 'q', 
        -with    => sub ($) { uc $_[0] }, 
    };
     
    say quc/do i have to $hout/;
     
    # => DO I HAVE TO $HOUT
=head1 DESCRIPTION
=head2 QUOTE-LIKE OPERATORS
Perl comes with some very handy Quote-Like Operators 
L<http://perldoc.perl.org/perlop.html#Quote-Like-Operators> :)
But what it doesn't come with is some easy method to create your own quote-like operators :(
This is where PerlX::QuoteOperator comes in.  Using the fiendish L<Devel::Declare> under its hood  
it "tricks", sorry "helps!" the perl parser to provide new first class quote-like operators.
=head2 HOW DOES IT DO IT?
The subterfuge doesn't go that deep.  If we take a look at the SYNOPSIS example:
    say quc/do i have to $hout/;
     
Then all PerlX::QuoteOperator actually does is convert this to the following before perl compiles it:
    say quc q/do i have to $hout/;
     
Where 'quc' is a defined sub expecting one argument  (ie, sub ($) { uc $_[0] }  ).
This approach allows PerlX::QuoteOperator to perform the very basic keyhole surgery on the code,
ie. just put in the emulated quote-like operator between keyword & argument.
However this approach does have caveats especially when qw// is being used!.  See CAVEATS.
There is an alternative parser when can be invoked,  see -parser Export parameter.
=head2 WHY?
Bit like climbing Mount Everest... because we can!  ;-)
Is really having something like:
    say quc/do i have to $hout/;
     
so much better than:
    say uc 'do i have to $hout';
     
or more apt this:
    say uc('do i have to $hout');
     
Probably not... at least in the example shown.  But things like this are certainly eye catching:
    use PerlX::QuoteOperator::URL 'qh';
     
    my $content = qh( http://transfixedbutnotdead.com );   # does HTTP request
NOTICE - As for version 0.05 (23rd Feb 2015), PerlX::QuoteOperator::URL was moved to its own distribution.
And this:
    use PerlX::QuoteOperator qwHash => { 
        -emulate    => 'qw',
        -with       => sub (@) { my $n; map { $_ => ++$n } @_ },
    };
    my %months = qwHash/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
Certainly give the code aesthetic a good pause for thought.
=head1 EXPORT
By default nothing is exported:
    use PerlX::QuoteOperator;    # => imports nothing
     
Quote operator is imported when passed a name and options like so:
    use PerlX::QuoteOperator quote_operator_name_i_want_to_use => { }   
A hashref is used to pass the options.
=head2 PARAMETERS
=head3 -emulate
Which Perl quote-like operator required to emulate.  q, qq & qw have all been tested.
Default: emulates qq
=head3 -with
Your quote-like operator code reference / anon subroutine goes here.
Remember to use subroutine prototype (if not using -parser option):
    -with    => sub ($) { uc $_[0] }, 
This is a mandatory parameter.
=head3 -parser
If set then alternative parser kicks in.   This parser currenly works on single line of code only
and must open/close quote with (), {}, [], <> or must have same delimeter for beginning and end of quote:
    -parser => 1
     
When invoked this parser will take this:
    quc/do i have to $hout/;
And by finding the end of the quote will then encapulate it like so:
    quc(q/do i have to $hout/);
Default: Not using alternative parsing.
=head3 -debug
If set then prints (warn) the transmogrified line so that you can see what PerlX::QuoteOperator has done!
    -debug => 1
Default:  No debug.
=head1 FUNCTIONS
=head2 import
Module import sub.
=head2 parser
When keyword (defined quote operator) is triggered then this sub uses L<Devel::Declare> 
to provide necessary keyhole surgery/butchery on the code to make it valid Perl code (think Macro here!).
=head2 _closing_delim
Internal subroutine used in -parser option.
=head1 CAVEATS
Performing a method call or dereference using -> like below will not work:
    use PerlX::QuoteOperator qurl => { 
        -emulate => 'q', 
        -with    => sub ($) { require URI; URI->new($_[0]) },
    };
     
    qurl(http://www.google.com/)->authority;   # Throws an error
Because the parsed qurl line becomes this...
    qurl q(http://www.google.com/)->authority;
... so throwing an error trying to call C<authority> on a string.  See "HOW DOES IT DO IT" for more info.  
A workaround is to use the I<alternative> parser and the line would now be parsed like this:
    qurl(q(http://www.google.com/))->authority;
     
See -parser option for more information.
Also see examples/qw.pl for some more issues with creating qw based quote-like operators. NB. The alternative parser will get around some of these problems but then (potentially) introduces a few new ones! (see TODO)
Recommendation: Stick with Perl parser and all will be fine! 
=head1 WRITING A QUOTE OPERATOR MODULE
This section shows how you can create a module that
defines a custom quote operator,
if you have one that you want to re-use.
Let's say you want a C<qROT13> operator,
which will L<ROT13|http://en.wikipedia.org/wiki/ROT13> a string.
First, here's a simple rot13 function.
Look at the <wikipedia page on rot13|http://en.wikipedia.org/wiki/ROT13>
if you're not familiar with rot13:
    my $rot13 = sub ($) {
        my $string = shift;
        $string =~ y/A-Za-z/N-ZA-Mn-za-m/;
        return $string;
    };
You don't create your module as a subclass of C<PerlX::QuoteOperator>,
but your module creates an instance of it, then calls its C<import()>
method, passing an additional final argument,
which specifies the name of the package
that the operator should be imported into.
Leaving out the rot13 function for ease of reading,
here's a module which defines the operator:
    package PerlX::QuoteOperator::Rot13;
    use PerlX::QuoteOperator ();
    sub import {
        my $class     = shift;
        my $name      = @_ > 0 ? shift : 'qROT13';
        my $export_to = caller();
        my $pqo       = PerlX::QuoteOperator->new();
        $pqo->import($name, { -emulate => 'qq', -with => $rot13 }, $export_to);
    }
    1;
You can now use your module as follows:
    use PerlX::QuoteOperator::Rot13;
    my $string = qROT13|This is a string|;
    print "string = '$string'\n";
=head1 SEE ALSO
=over 4
=item * L<PerlX::QuoteOperator::URL>
=back
=head1 CONTRIBUTORS
Toby Inkster (L<https://metacpan.org/author/TOBYINK>) for Text::Balanced patch to the alternative parser at 0.04
=head1 AUTHOR
Barry Walsh, C<< <draegtun at cpan.org> >>
=head1 BUGS
Please report any bugs or feature requests to L<https://github.com/draegtun/PerlX-QuoteOperator/issues>
=head1 SUPPORT
You can find documentation for this module with the perldoc command.
    perldoc PerlX::QuoteOperator
You can also look for information at:
=over 4
=item * Github issues & push requests
L<https://github.com/draegtun/PerlX-QuoteOperator/issues>
=item * Old resolved bugs can be found on RT: CPAN's request tracker
L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=PerlX-QuoteOperator>
=item * AnnoCPAN: Annotated CPAN documentation
L<http://annocpan.org/dist/PerlX-QuoteOperator>
=item * CPAN Ratings
L<http://cpanratings.perl.org/d/PerlX-QuoteOperator>
=item * Search CPAN
L<http://search.cpan.org/dist/PerlX-QuoteOperator/>
L<https://metacpan.org/pod/PerlX::QuoteOperator/>
=back
=head1 ACKNOWLEDGEMENTS
From here to oblivion!:  L<http://transfixedbutnotdead.com/2009/12/16/url-develdeclare-and-no-strings-attached/>
And a round of drinks for the mad genius of L<MST|http://search.cpan.org/~mstrout/> for creating L<Devel::Declare> in the first place!
=head1 DISCLAIMER
This is (near) beta software.   I'll strive to make it better each and every day!
However I accept no liability I<whatsoever> should this software do what you expected ;-)
=head1 COPYRIGHT & LICENSE
Copyright 2009-2015 Barry Walsh (Draegtun Systems Ltd | L<http://www.draegtun.com>), all rights reserved.
This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.
See http://dev.perl.org/licenses/ for more information.