view release on metacpan or  search on metacpan

lib/Mojolicious/Plugin/PlainRoutes.pm  view on Meta::CPAN

use 5.014;
package Mojolicious::Plugin::PlainRoutes;
# ABSTRACT: Plaintext route definitions for Mojolicious
$Mojolicious::Plugin::PlainRoutes::VERSION = '0.07';
use Mojo::Base 'Mojolicious::Plugin';
use Mojo::Util qw/decamelize/;

has autoname => 0;

sub register {
	my ($self, $app, $conf) = @_;

	$self->autoname($conf->{autoname});

	$conf->{file} //= $app->home->rel_file("lib/".$app->moniker.".routes");

	open my $fh, '<:encoding(UTF-8)', $conf->{file};
	my $tree = $self->tokenise($fh);
	close $fh;

	$self->process($app->routes, $tree);
}

sub tokenise {
	my ($self, $input) = @_;

	if (ref $input eq 'GLOB') {
		$input = do { local $/; <$input> };
	} elsif (ref $input) {
		Carp::carp "Non-filehandle reference passed to tokenise";
		return [];
	}

	return $self->_tokenise($input);
}

sub _tokenise {
	my ($self, $input) = @_;

	$input =~ s/\r\n/\n/g;
	$input =~ s/\n\r/\n/g;
	$input =~ s/\r/\n/g;

	my %grammar = (
		comment    => qr{ \# [^\n]* }x,
		verb       => qr{ ANY | DELETE | GET | PATCH | POST | PUT }x,
		path       => qr{ / [^#\s]* }x,
		arrow      => qr{ -> }x,
		scope      => qr( { | } )x,
		action     => qr{ [\w\-:]* \. \w* }x,
		name       => qr{ \( [^)]+ \) }x,
		eol        => qr{ \n }x,
		space      => qr{ [^\S\n]+ }x,
	);

	my @words = grep { defined && length }
	              split m{( $grammar{comment}
	                      | $grammar{verb}
	                      | $grammar{path}
	                      | $grammar{arrow}
	                      | $grammar{scope}
	                      | $grammar{action}
	                      | $grammar{name}
	                      | $grammar{eol}
	                      | $grammar{space}
	                      )}x, $input;

	# Include the lexical category with the word, e.g., map:
	#   "/foo" -> { text => "/foo", category => "path" }
	my @annotated_words;
	for my $word (@words) {
		my @cats = grep { $word =~ /^$grammar{$_}$/ } keys %grammar;

		if (@cats > 1) {
			warn "$word has multiple lexical categories: @cats";
		}

		push @annotated_words, { text => $word, category => $cats[0] // '' };
	}

	# Add special EOF word to act as a clause terminator if necessary
	push @annotated_words, { text => '', category => 'eof' };

	# Initialise
	my $root    = [];
	my @nodes   = ($root);
	my %clause  = ();
	my $context = 'default';

	# Track for helpful error messages
	my $col = 1;
	my $line = 1;
	my $error = 0;

	# Define outside the loop scope so that the closure can access it
	my %word;

	# Called whenever a syntax error is encountered.
	my $syntax_error = sub {
		$error = 1;
		my $_col = $col - length $word{text};
		print STDERR qq{Syntax error in routes on line $line, col $_col: }
		          .  qq{"$word{text}" (expected a @_)\n};
	};

	for (@annotated_words) {
		%word = %$_;
		$col += length $word{text};
		if ($word{category} eq 'eol') {
			$line += 1;
			$col = 1;
		}

		# While in comment context, the parser checks for newlines and
		# otherwise does nothing.
		if ($context eq 'comment') {
			if ($word{category} eq 'eol') {