File Coverage

blib/lib/Syntax/Feature/Qi.pm

Criterion	Covered	Total	%
statement	57	57	100.0
branch	4	6	66.6
condition			n/a
subroutine	13	13	100.0
pod	0	1	0.0
total	74	77	96.1

use strict;
use warnings;

package Syntax::Feature::Qi;

our $VERSION = '0.2002'; # VERSION
# ABSTRACT: Remove the same indendation from all lines in a string

use Devel::Declare 0.006007 ();
use B::Hooks::EndOfScope 0.09;
use Sub::Install 0.925 qw/install_sub/;
use Devel::Declare::Context::Simple;
use namespace::clean;

my %quote_op = qw(qi q qqi qq);
my @new_ops = keys %quote_op;

sub install {
    my $class = shift;
    my %args = @_;

    my $target = $args{'into'};

    Devel::Declare->setup_for($target => {
        map {
            my $name = $_;
            ($name => {
                const => sub {
                    my $context = Devel::Declare::Context::Simple->new;
                    $context->init(@_);
                    return $class->_transform($name, $context);
                },
            });
        } @new_ops
    });
    foreach my $name (@new_ops) {
        install_sub {
            into => $target,
            as => $name,
            code => $class->_run_callback,
        };
    }
    on_scope_end {
        namespace::clean->clean_subroutines($target, @new_ops);
    };
    return 1;
}

sub _run_callback {

    return sub ($) {
        my $string = shift;
        return $string if $string =~ m{\A\s*\Z}ms;

        my $remove_indent = $string =~ m{\A(\h*)\S}      ? $1
                          : $string =~ m{\A\s*\n(\h*)\S} ? $1
                          :                                ''
                          ;
        $string =~ s{^$remove_indent}{}gms;
        return $string;
    };
}

sub _transform {
    my $class = shift;
    my $name = shift;
    my $ctx = shift;

    $ctx->skip_declarator;
    my $length = Devel::Declare::toke_scan_str($ctx->offset);
    my $string = Devel::Declare::get_lex_stuff;
    Devel::Declare::clear_lex_stuff;
    my $linestr = $ctx->get_linestr;
    my $quoted = substr $linestr, $ctx->offset, $length;
    my $spaced = '';
    $quoted =~ m{^(\s*)}sm;
    $spaced = $1;
    my $new = sprintf '(%s)', join '',
        $quote_op{$name},
        $spaced,
        substr($quoted, length($spaced), 1),
        $string,
        substr($quoted, -1, 1);
    substr($linestr, $ctx->offset, $length) = $new;
    $ctx->set_linestr($linestr);
    return 1;
}

1;

__END__

=pod

=encoding utf-8

=head1 NAME

Syntax::Feature::Qi - Remove the same indendation from all lines in a string

=head1 VERSION

Version 0.2002, released 2015-01-17.

=head1 SYNOPSIS

    use syntax 'qi';

    say qi{
        This is a sub routine:
        sub printme {
            print shift;
        }
    };

    # is exactly the same as

    say qi{
    This is a sub routine:
    sub printme {
        print shift;
    }
    };

=head1 DESCRIPTION

This is a syntax extension to be used with L<syntax>.

It provides two quote-like operators, C<qi> and C<qqi>. They are drop-in replacements for C<q> and C<qq>, respectively.

They work like this: First they find the first line in the string with a non-white space character. It saves the
white space from the beginning of that line up to that character, and then it tries to remove the exact same whitespace from
all other lines in the string.

=head1 SEE ALSO

=over 4

=item *

L<Syntax::Feature::Ql> (which served as a base for this)

=item *

L<Syntax::Feature::Qs>

=item *

L<String::Nudge>

=item *

L<syntax>

=back

=head1 SOURCE

L<https://github.com/Csson/p5-Syntax-Feature-Qi>

=head1 HOMEPAGE

L<https://metacpan.org/release/Syntax-Feature-Qi>

=head1 AUTHOR

Erik Carlsson <[e-mail]>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2015 by Erik Carlsson.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut