view release on metacpan or  search on metacpan

lib/CatalystX/ASP/Parser.pm  view on Meta::CPAN

    }
    return $parsed_object;
}

=item $self->parse_file($c, $file)

Take a C<$file> and returns a hash including parsed data

=cut

sub parse_file {
    my ( $self, $c, $file ) = @_;

    my $scriptref = eval { read_file( $file, scalar_ref => 1 ); };

    # Asssume $@ =~ /sysopen: No such file or directory/
    # Don't want to parse error because of possibly different locale than en_US.UTF-8
    if ( $@ ) {

        # To get to this point would mean that some call to $Response->Include()
        # is for a non-existent file
        $c->error( "Could not read_file: $file in parse_file: $@" );
        $c->detach;
    }

    my $parsed_object = $self->parse( $c, $scriptref );

    $parsed_object->{file} = $file;

    return $parsed_object;
}

# This parser processes and converts are SSI to call $Response->Include()
sub _parse_ssi {
    my ( $self, $c, $scriptref ) = @_;

    my $data = '';
    my $file_line_number;
    my $is_code_block;

    return \$data unless $$scriptref;

    while ( $$scriptref =~ s/^(.*?)\<!--\#include\s+file\s*=\s*\"?([^\s\"]*?)\"?(\s+args\s*=\s*\"?.*?)?\"?\s*--\>//so ) {
        $data .= $1;    # append the head
        my $include = $2;
        my $args;
        if ( $3 ) {
            $args = $3;
            $args =~ s/^\s+args\s*\=\s*\"?//sgo;
        }

        my $head_data = $1;
        if ( $head_data =~ s/.*\n\#line (\d+) [^\n]+\n(\%\>)?//s ) {
            $file_line_number = $1;
            $is_code_block = $2 ? 0 : 1;
        }
        $file_line_number += $head_data =~ s/\n//sg;
        $head_data =~ s/\<\%.*?\%\>//sg;
        $is_code_block += $head_data =~ s/\<\%//sg;
        $is_code_block -= $head_data =~ s/\%\>//sg;
        $is_code_block = $is_code_block > 0;    # stray percents like height=100%> kinds of tags

        # global directory, as well as includes dirs
        $c->error( "Could not find $include in IncludesDir" )
            unless $self->search_includes_dir( $include );

        # because the script is literally different whether there
        # are includes or not, whether we are compiling includes
        # need to be part of the script identifier, so the global
        # caching does not return a script with different preferences.
        $args ||= '';
        $data .= "<% \$Response->Include('$include', '$args'); %>";

        # compile include now, so Loading() works for dynamic includes too
        $c->error( "Failed to compile $include" )
            unless $self->compile_include( $c, $include );
    }
    $data .= $$scriptref;    # append what's left

    return \$data;
}

# Where the real ASP parsing happens. It's actually decently simple, just don't
# look at the Parse() from the original author.
sub _parse_asp {
    my ( $self, $c, $scriptref ) = @_;

    $$scriptref = $self->_parse_xml_subs( $c, $$scriptref ) if $self->XMLSubsMatch;

    # This is where we start to throw data back that lets the system render a
    # static file as is instead of executing it as a per subroutine.
    return unless $$scriptref =~ /\<\%.*?\%\>/s;

    $scriptref = \join( '', $$scriptref, '<%;;;%>' );    # always end with some perl code for parsing.

    my ( $script, @out, $perl_block, $last_perl_block );
    while ( $$scriptref =~ s/^(.*?)\<\%(.*?)\%\>//so ) {
        my ( $text, $perl ) = ( $1, $2 );
        my $is_perl_block = $perl !~ /^\s*\=(.*)$/so;

        # with some extra text parsing, we remove asp formatting from
        # influencing the generated html formatting, in particular
        # dealing with perl blocks and new lines
        if ( $text ) {

            # don't touch the white space, to preserve line numbers
            $text =~ s/\\/\\\\/gso;
            $text =~ s/\'/\\\'/gso;

            $last_perl_block = 0 if $last_perl_block;

            push @out, "\'$text\'";
        }

        if ( $perl ) {
            unless ( $is_perl_block ) {

                # we have a scalar assignment here
                push( @out, "($1)" );
            } else {
                $last_perl_block = 1;