#!/usr/local/bin/perl

use 5.006;

use strict;
use warnings;

BEGIN {
    if ( '5.008' le $] ) {
	# Have to prevent Perl from parsing 'open' as 'CORE::open'.
	require 'open.pm';
	'open'->import( qw{ :std :encoding(utf-8) } );
    }
}

use Getopt::Long 2.33 qw{ :config auto_version };
use Pod::Usage;
use PPI::Document;
use PPIx::Regexp::Dumper;
use Scalar::Util qw{ refaddr };

use vars qw{ $VERSION };

$VERSION = '0.091';

my %opt = (
    default_modifiers => [],
    verbose => 0,
);

GetOptions( \%opt,
    help => sub { pod2usage ( {
		-exitval	=> 0,
		-verbose	=> 2,
		-output		=> \*STDOUT,
	    } )
    },
    qw{
        default_modifiers|default-modifiers=s@
	encoding=s explain! files!
	indent=i locations! margin=i objectify! ordinal!
	perl_version|perl-version!
	ppi! short! significant! strict!
	test! tokens! trace+ unescape! verbose width! +
    } )
    and @ARGV
    or pod2usage( {
	-exitval	=> 2,
	-verbose	=> 1,
	-output		=> \*STDERR,
    } );

$opt{default_modifiers} = [ map { split qr{ \s* , \s* }smx } @{
    $opt{default_modifiers} } ];

foreach my $re ( process_args( \%opt, @ARGV ) ) {

    if ( ! $opt{test} ) {
	my @output = ( "\n$re" );
	@{ $opt{default_modifiers} }
	    and push @output, q{default_modifiers => '} . join( ',', @{
		$opt{default_modifiers} } ) . q{'};
	print join( "\t", @output ), "\n";
	@output = item_info( $re )
	    and print join( "\t", @output ), "\n";
    }

    PPIx::Regexp::Dumper->new( $re, %opt )->print();

}

{

    my @docs;	# Have to save reference

    my %file;

    sub process_args {
	my ( $opt, @args ) = @_;

	my @rslt;
	foreach my $datum ( @args ) {

	    if ( $opt->{files} ) {

		my $doc = PPI::Document->new( $datum, readonly => 1 )
		    or die "Can not make PPI::Document from file '$datum'\n";
		push @docs, $doc;
		push @rslt, extract_res( $doc, $opt );
		$file{ refaddr( $doc ) } = {
		    name	=> $datum,
		};

	    } else {

		$opt->{unescape}
		    and $datum =~ s/ \\\\ /\\/smxg;

		if ( $opt->{objectify} ) {

		    my $doc = PPI::Document->new( \$datum )
			or die "Can not make PPI::Document from '$datum'\n";
		    push @docs, $doc;
		    push @rslt, extract_res( $doc, $opt );

		} else {

		    push @rslt, $datum;

		}
	    }
	}

	delete $opt->{files};
	delete $opt->{objectify};
	delete $opt->{unescape};

	return @rslt;
    }

    sub item_info {
	my ( $obj ) = @_;
	ref $obj
	    or return;
	eval {
	    $obj->isa( 'PPI::Element' );
	} or return;
	my $doc = $obj->document()
	    or return;
	my $info = $file{ refaddr $doc }
	    or return;
	return wantarray ?
	    ( $info->{name}, @{ $obj->location() || [] }[0, 2] ) :
	    $info->{name};
    }
}

{
    my ( %classes, @regex, @string );

    BEGIN {
	@regex = qw{
	    PPI::Token::QuoteLike::Regexp
	    PPI::Token::Regexp::Match
	    PPI::Token::Regexp::Substitute
	};
	@string = qw{
	    PPI::Token::Quote
	    PPI::Token::QuoteLike::Command
	    PPI::Token::QuoteLike::BackTick
	    PPI::Token::HereDoc
	};
	%classes = (
	    guess	=> [ @regex, @string ],
	    regex	=> \@regex,
	    string	=> \@string,
	);
    }

    sub extract_res {
	my ( $doc, $opt ) = @_;
	my $parse = $opt->{parse} || 'regex';
	'regex' eq $parse
	    and return PPIx::Regexp->extract_regexps( $doc );
	# TODO get rid of this whole mess in favor of the above line
	# once the string functionality goes away.
	return (
	    map { @{ $doc->find( $_ ) || [] } } @{
	    $classes{$parse} || $classes{regex} }
	);
    }
}

__END__

=head1 NAME

predump - Dump a regular expression

=head1 SYNOPSIS

 predump 'qr{foo}smx'
 predump --ordinal 'm/foo/x'

You can use

 predump --help

for full documentation on usage.

=head1 DESCRIPTION

This Perl script parses the regular expression given on its command line
and dumps the results of the parse to standard out. Options are accepted
with leading single dashes as well as double dashes. The following
options are recognized:

=over

=item --default-modifiers text

This option specifies default modifiers for the regular expression. You
can specify more than one, either as a comma-separated list or by
specifying the option multiple times, or both. It is simply passed
through to L<< PPIx::Regexp->new()|PPIx::Regexp/new >>.

This option can also be expressed as C<--default_modifiers>.

=item --encoding name

This option specifies the encoding of the regular expression. It is
simply passed through to L<< PPIx::Regexp->new()|PPIx::Regexp/new >>.

=item --files

If true, this option specifies that the arguments are files whose
regular expressions are to be analyzed. If this options is asserted,
C<--objectify> and C<--unescape> are ignored.

=item --help

This option displays the documentation for this script. The script then
exits.

=item --indent number

This option specifies the number of spaces to indent each level of the
parse hierarchy. It is simply passed through to
L<< PPIx::Regexp::Dumper->new()|PPIx::Regexp::Dumper/new >>.

=item --margin number

This option specifies the width of the left margin of the dump output.
It is simply passed through to
L<< PPIx::Regexp::Dumper->new()|PPIx::Regexp::Dumper/new >>.

=item --objectify

If true, this option specifies that the arguments should be made into
L<PPI::Token|PPI::Token> objects before being passed to PPIx::Regexp.
This option is ignored if C<--files> is asserted.

=item --ordinal

If true, this option specifies that the ordinal value of all
L<PPIx::Regexp::Token::Literal|PPIx::Regexp::Token::Literal> objects be
displayed as part of the dump. The default is false. This is simply
passed through to
L<< PPIx::Regexp::Dumper->new()|PPIx::Regexp::Dumper/new >>.

=item --perl-version

If true, this option specifies that the dump include the perl version
applicable to each dumped item. The default is false. This is simply
passed through to
L<< PPIx::Regexp::Dumper->new()|PPIx::Regexp::Dumper/new >>.

This option can also be expressed as C<--perl_version>.

=item --significant

If true, this option specifies that the dump include only significant
syntax elements. That is, no comments or non-significant white space.
The default is false. This is simply passed through to
L<< PPIx::Regexp::Dumper->new()|PPIx::Regexp::Dumper/new >>.

=item --short

If true, this option specifies that class names in the dump will have
the leading C<'PPIx::Regexp::'> removed.  This is simply passed through
to L<< PPIx::Regexp::Dumper->new()|PPIx::Regexp::Dumper/new >>.

=item --test

If true, this option specifies that the dump take the form of a
predefined set of tests be generated for the regular expression. This
option is unsupported in the sense that the author makes no commitment
to what it will do, and reserves the right to change it without notice.
This is simply passed through to
L<< PPIx::Regexp::Dumper->new()|PPIx::Regexp::Dumper/new >>.

=item --tokens

If true, this option specifies that only tokenization be done on the
regular expression, and the output tokens dumped to standard out.
This is simply passed through to
L<< PPIx::Regexp::Dumper->new()|PPIx::Regexp::Dumper/new >>.

=item --trace

If true, this option specifies the generation of trace output from the
parse. It is unsupported in the sense that the author makes no
commitment to what it will do, and reserves the right to change it
without notice.  This is simply passed through to
L<< PPIx::Regexp->new()|PPIx::Regexp/new >>.

=item --unescape

If true, this option causes the argument to be unescaped before
processing. You would use it if the argument is a Perl single-quotish
string, since Perl's single-quoted syntax differs from that of the usual
Unix shell. This option is ignored if C<-files> is asserted.

=item --verbose

If true, this option causes more information to be dumped about each
object produced by the parse.  It is unsupported in the sense that the
author makes no commitment to what it will do, and reserves the right to
change it without notice. This is simply passed through to L<<
PPIx::Regexp::Dumper->new()|PPIx::Regexp::Dumper/new >>.

=item --version

This option displays the version of this script. The script then exits.

=item --width

If true, this option causes the width of the object to be dumped.

=back

=head1 SUPPORT

Support is by the author. Please file bug reports at
L<https://rt.cpan.org/Public/Dist/Display.html?Name=PPIx-Regexp>,
L<https://github.com/trwyant/perl-PPIx-Regexp/issues>, or in
electronic mail to the author.

=head1 AUTHOR

Thomas R. Wyant, III F<wyant at cpan dot org>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2009-2023, 2025 by Thomas R. Wyant, III

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl 5.10.0. For more details, see the full text
of the licenses in the directory LICENSES.

This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.

=cut

# ex: set textwidth=72 :