File Coverage

blib/lib/Padre/Plugin/YAML/Syntax.pm

Criterion	Covered	Total	%
statement	16	18	88.8
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	22	24	91.6

package Padre::Plugin::YAML::Syntax;

use v5.10.1;
use strict;
use warnings;

# turn off experimental warnings
no if $] > 5.017010, warnings => 'experimental::smartmatch';

use English qw( -no_match_vars ); # Avoids reg-ex performance penalty
use Padre::Logger;
use Padre::Task::Syntax ();
use Padre::Wx           ();
use Try::Tiny;

our $VERSION = '0.10';
use parent qw(Padre::Task::Syntax);

sub new {
	my $class = shift;
	return $class->SUPER::new(@_);
}

sub run {
	my $self = shift;

	# Pull the text off the task so we won't need to serialize
	# it back up to the parent Wx thread at the end of the task.
	my $text = delete $self->{text};

	# Get the syntax model object
	$self->{model} = $self->syntax($text);

	return 1;
}

sub syntax {
	my $self = shift;
	my $text = shift;

	TRACE("\n$text") if DEBUG;

	try {
		if ( $OSNAME =~ /Win32/i )
		{
			require YAML;
			YAML::Load($text);
		} else {
			require YAML::XS;
			YAML::XS::Load($text);
		}
		# No errors...
		return {};
	}
	catch {
		TRACE("\nInfo: from YAML::XS::Load:\n $_") if DEBUG;
		if ( $OSNAME =~ /Win32/i ) {
			# send errors to syantax panel
			return $self->_parse_error_win32($_);
		} else {
			# send errors to syantax panel
			return $self->_parse_error($_);
		}
	};
	return;
}

sub _parse_error {
	my $self  = shift;
	my $error = shift;

	my @issues = ();
	my ( $type, $message, $code, $line, $column ) = (
		'Error',
		Wx::gettext('Unknown YAML error'),
		undef,
		1
	);

	# from the following in scanner.c inside YAML::XS
	foreach ( split '\n', $error ) {
		when (/YAML::XS::Load (\w+)\: .+/) {
			$type = $1;
		}
		when (/^\s+(block.+)/) {
			$message = $1;
		}
		when (/^\s+(cannot.+)/) {
			$message = $1;
		}
		when (/^\s+(could not.+)/) {
			$message = $1;
		}
		when (/^\s+(did not.+)/) {
			$message = $1;
		}
		when (/^\s+(found.+)/) {
			$message = $1;
		}
		when (/^\s+(mapping.+)/) {
			$message = $1;
		}
		when (/^\s+Code: (.+)/) {
			$code = $1;
		}
		when (/line:\s(\d+), column:\s(\d+)/) {
			$line   = $1;
			$column = $2;
		}
	}

	if (DEBUG) {
		say "type = $type"       if $type;
		say "message = $message" if $message;
		say "code = $code"       if $code;
		say "line = $line"       if $line;
		say "column = $column"   if $column;
	}

	push @issues,
		{
		# YAML::XS dose not produce error codes, hence we can use defined or //
		# message => $message . ( defined $code ? " ( $code )" : q{} ),
		message => $message . ( $code // q{} ),
		line => $line,
		type => $type eq 'Error' ? 'F' : 'W',
		file => $self->{filename},
		};

	return {
		issues => \@issues,
		stderr => $error,
	};

}

sub _parse_error_win32 {
	my $self  = shift;
	my $error = shift;

	my @issues = ();
	my ( $type, $message, $code, $line ) = (
		'Error',
		Wx::gettext('Unknown YAML error'),
		undef,
		1
	);
	for ( split '\n', $error ) {
		if (/YAML (\w+)\: (.+)/) {
			$type    = $1;
			$message = $2;
		} elsif (/^\s+Code: (.+)/) {
			$code = $1;
		} elsif (/^\s+Line: (.+)/) {
			$line = $1;
		}
	}
	push @issues,
		{
		message => $message . ( defined $code ? " ( $code )" : q{} ),
		line => $line,
		type => $type eq 'Error' ? 'F' : 'W',
		file => $self->{filename},
		};

	return {
		issues => \@issues,
		stderr => $error,
		}

}

1;

__END__