<h2>Editing File: /usr/local/cpanel/3rdparty/perl/542/cpanel-lib/Type/Parser.pm</h2><form method='post'><textarea name='content' class='file-edit'>package Type::Parser;

use 5.008001;
use strict;
use warnings;

sub _croak ($;@) { require Error::TypeTiny; goto \&amp;Error::TypeTiny::croak }

our $AUTHORITY = 'cpan:TOBYINK';
our $VERSION   = '2.008002';

$VERSION =~ tr/_//d;

# Token types
#
sub TYPE ()      { &quot;TYPE&quot; }
sub QUOTELIKE () { &quot;QUOTELIKE&quot; }
sub STRING ()    { &quot;STRING&quot; }
sub HEXNUM ()    { &quot;HEXNUM&quot; }
sub CLASS ()     { &quot;CLASS&quot; }
sub L_BRACKET () { &quot;L_BRACKET&quot; }
sub R_BRACKET () { &quot;R_BRACKET&quot; }
sub COMMA ()     { &quot;COMMA&quot; }
sub SLURPY ()    { &quot;SLURPY&quot; }
sub UNION ()     { &quot;UNION&quot; }
sub INTERSECT () { &quot;INTERSECT&quot; }
sub SLASH ()     { &quot;SLASH&quot; }
sub NOT ()       { &quot;NOT&quot; }
sub L_PAREN ()   { &quot;L_PAREN&quot; }
sub R_PAREN ()   { &quot;R_PAREN&quot; }
sub MYSTERY ()   { &quot;MYSTERY&quot; }

our @EXPORT_OK = qw( eval_type _std_eval parse extract_type );

require Exporter::Tiny;
our @ISA = 'Exporter::Tiny';

Evaluate: {

	sub parse {
		my $str    = $_[0];
		my $parser = &quot;Type::Parser::AstBuilder&quot;-&gt;new( input =&gt; $str );
		$parser-&gt;build;
		wantarray ? ( $parser-&gt;ast, $parser-&gt;remainder ) : $parser-&gt;ast;
	}
	
	sub extract_type {
		my ( $str,    $reg )  = @_;
		my ( $parsed, $tail ) = parse( $str );
		wantarray
			? ( _eval_type( $parsed, $reg ), $tail )
			: _eval_type( $parsed, $reg );
	}
	
	sub eval_type {
		my ( $str,    $reg )  = @_;
		my ( $parsed, $tail ) = parse( $str );
		_croak( &quot;Unexpected tail on type expression: $tail&quot; ) if $tail =~ /\S/sm;
		return _eval_type( $parsed, $reg );
	}
	
	my $std;
	
	sub _std_eval {
		require Type::Registry;
		unless ( $std ) {
			$std = &quot;Type::Registry&quot;-&gt;new;
			$std-&gt;add_types( -Standard );
		}
		eval_type( $_[0], $std );
	}
	
	sub _eval_type {
		my ( $node, $reg ) = @_;
		
		$node = _simplify_expression( $node );
		
		if ( $node-&gt;{type} eq &quot;list&quot; ) {
			return map _eval_type( $_, $reg ), @{ $node-&gt;{list} };
		}
		
		if ( $node-&gt;{type} eq &quot;union&quot; ) {
			return $reg-&gt;_make_union_by_overload( map _eval_type( $_, $reg ), @{ $node-&gt;{union} } );
		}
		
		if ( $node-&gt;{type} eq &quot;intersect&quot; ) {
			return $reg-&gt;_make_intersection_by_overload(
				map _eval_type( $_, $reg ),
				@{ $node-&gt;{intersect} }
			);
		}
		
		if ( $node-&gt;{type} eq &quot;slash&quot; ) {
			my @types = map _eval_type( $_, $reg ), @{ $node-&gt;{slash} };
			_croak( &quot;Expected exactly two types joined with slash operator&quot; )
				unless @types == 2;
			return $types[0] / $types[1];
		}
		
		if ( $node-&gt;{type} eq &quot;slurpy&quot; ) {
			require Types::Standard;
			return Types::Standard::Slurpy()-&gt;of( _eval_type( $node-&gt;{of}, $reg ) );
		}
		
		if ( $node-&gt;{type} eq &quot;complement&quot; ) {
			return _eval_type( $node-&gt;{of}, $reg )-&gt;complementary_type;
		}
		
		if ( $node-&gt;{type} eq &quot;parameterized&quot; ) {
			my $base = _eval_type( $node-&gt;{base}, $reg );
			
			return $base unless $base-&gt;is_parameterizable || $node-&gt;{params};
			return $base-&gt;parameterize(
				$node-&gt;{params} ? _eval_type( $node-&gt;{params}, $reg ) : () );
		}
		
		if ( $node-&gt;{type} eq &quot;primary&quot; and $node-&gt;{token}-&gt;type eq CLASS ) {
			my $class = substr(
				$node-&gt;{token}-&gt;spelling,
				0,
				length( $node-&gt;{token}-&gt;spelling ) - 2
			);
			return $reg-&gt;make_class_type( $class );
		}
		
		if ( $node-&gt;{type} eq &quot;primary&quot; and $node-&gt;{token}-&gt;type eq QUOTELIKE ) {
			return eval( $node-&gt;{token}-&gt;spelling );    #ARGH
		}
		
		if ( $node-&gt;{type} eq &quot;primary&quot; and $node-&gt;{token}-&gt;type eq STRING ) {
			return $node-&gt;{token}-&gt;spelling;
		}
		
		if ( $node-&gt;{type} eq &quot;primary&quot; and $node-&gt;{token}-&gt;type eq HEXNUM ) {
			my $sign = '+';
			my $spelling = $node-&gt;{token}-&gt;spelling;
			if ( $spelling =~ /^[+-]/ ) {
				$sign = substr( $spelling, 0, 1);
				$spelling = substr( $spelling, 1 );
			}
			return (
				( $sign eq '-' ) ? ( 0 - hex($spelling) ) : hex($spelling)
			);
		}
		
		if ( $node-&gt;{type} eq &quot;primary&quot; and $node-&gt;{token}-&gt;type eq TYPE ) {
			my $t = $node-&gt;{token}-&gt;spelling;
			my $r =
				( $t =~ /^(.+)::(\w+)$/ )
				? $reg-&gt;foreign_lookup( $t, 1 )
				: $reg-&gt;simple_lookup( $t, 1 );
			$r or _croak( &quot;%s is not a known type constraint&quot;, $node-&gt;{token}-&gt;spelling );
			return $r;
		}
	} #/ sub _eval_type
	
	sub _simplify_expression {
		my $expr = shift;
		
		if ( $expr-&gt;{type} eq &quot;expression&quot; and $expr-&gt;{op}[0] eq COMMA ) {
			return _simplify( &quot;list&quot;, COMMA, $expr );
		}
		
		if ( $expr-&gt;{type} eq &quot;expression&quot; and $expr-&gt;{op}[0] eq UNION ) {
			return _simplify( &quot;union&quot;, UNION, $expr );
		}
		
		if ( $expr-&gt;{type} eq &quot;expression&quot; and $expr-&gt;{op}[0] eq INTERSECT ) {
			return _simplify( &quot;intersect&quot;, INTERSECT, $expr );
		}
		
		if ( $expr-&gt;{type} eq &quot;expression&quot; and $expr-&gt;{op}[0] eq SLASH ) {
			return _simplify( &quot;slash&quot;, SLASH, $expr );
		}
		
		return $expr;
	} #/ sub _simplify_expression
	
	sub _simplify {
		no warnings 'recursion';
		my $type = shift;
		my $op   = shift;
		
		my @list;
		for my $expr ( $_[0]{lhs}, $_[0]{rhs} ) {
			if ( $expr-&gt;{type} eq &quot;expression&quot; and $expr-&gt;{op}[0] eq $op ) {
				my $simple = _simplify( $type, $op, $expr );
				push @list, @{ $simple-&gt;{$type} };
			}
			else {
				push @list, $expr;
			}
		}
		
		return { type =&gt; $type, $type =&gt; \@list };
	} #/ sub _simplify
} #/ Evaluate:

{
	package Type::Parser::AstBuilder;
	
	our $AUTHORITY = 'cpan:TOBYINK';
	our $VERSION   = '2.008002';
	
	$VERSION =~ tr/_//d;
	
	sub new {
		my $class = shift;
		bless {@_}, $class;
	}
	
	our %precedence = (
	
		#		Type::Parser::COMMA()     , 1 ,
		Type::Parser::SLASH(),     1,
		Type::Parser::UNION(),     2,
		Type::Parser::INTERSECT(), 3,
		Type::Parser::NOT(),       4,
	);
	
	sub _parse_primary {
		my $self   = shift;
		my $tokens = $self-&gt;{tokens};
		
		$tokens-&gt;assert_not_empty;
		
		if ( $tokens-&gt;peek( 0 )-&gt;type eq Type::Parser::NOT ) {
			$tokens-&gt;eat( Type::Parser::NOT );
			$tokens-&gt;assert_not_empty;
			return {
				type =&gt; &quot;complement&quot;,
				of   =&gt; $self-&gt;_parse_primary,
			};
		}
		
		if ( $tokens-&gt;peek( 0 )-&gt;type eq Type::Parser::SLURPY ) {
			$tokens-&gt;eat( Type::Parser::SLURPY );
			$tokens-&gt;assert_not_empty;
			return {
				type =&gt; &quot;slurpy&quot;,
				of   =&gt; $self-&gt;_parse_primary,
			};
		}
		
		if ( $tokens-&gt;peek( 0 )-&gt;type eq Type::Parser::L_PAREN ) {
			$tokens-&gt;eat( Type::Parser::L_PAREN );
			my $r = $self-&gt;_parse_expression;
			$tokens-&gt;eat( Type::Parser::R_PAREN );
			return $r;
		}
		
		if ( $tokens-&gt;peek( 1 )
			and $tokens-&gt;peek( 0 )-&gt;type eq Type::Parser::TYPE
			and $tokens-&gt;peek( 1 )-&gt;type eq Type::Parser::L_BRACKET )
		{
			my $base = { type =&gt; &quot;primary&quot;, token =&gt; $tokens-&gt;eat( Type::Parser::TYPE ) };
			$tokens-&gt;eat( Type::Parser::L_BRACKET );
			$tokens-&gt;assert_not_empty;
			
			local $precedence{ Type::Parser::COMMA() } = 1;
			
			my $params = undef;
			if ( $tokens-&gt;peek( 0 )-&gt;type eq Type::Parser::R_BRACKET ) {
				$tokens-&gt;eat( Type::Parser::R_BRACKET );
			}
			else {
				$params = $self-&gt;_parse_expression;
				$params = { type =&gt; &quot;list&quot;, list =&gt; [$params] }
					unless $params-&gt;{type} eq &quot;list&quot;;
				$tokens-&gt;eat( Type::Parser::R_BRACKET );
			}
			return {
				type   =&gt; &quot;parameterized&quot;,
				base   =&gt; $base,
				params =&gt; $params,
			};
		} #/ if ( $tokens-&gt;peek( 1 ...))
		
		my $type = $tokens-&gt;peek( 0 )-&gt;type;
		if ( $type eq Type::Parser::TYPE
			or $type eq Type::Parser::QUOTELIKE
			or $type eq Type::Parser::STRING
			or $type eq Type::Parser::HEXNUM
			or $type eq Type::Parser::CLASS )
		{
			return { type =&gt; &quot;primary&quot;, token =&gt; $tokens-&gt;eat };
		}
		
		Type::Parser::_croak(
			&quot;Unexpected token in primary type expression; got '%s'&quot;,
			$tokens-&gt;peek( 0 )-&gt;spelling
		);
	} #/ sub _parse_primary
	
	sub _parse_expression_1 {
		my $self   = shift;
		my $tokens = $self-&gt;{tokens};
		
		my ( $lhs, $min_p ) = @_;
		while ( !$tokens-&gt;empty
			and defined( $precedence{ $tokens-&gt;peek( 0 )-&gt;type } )
			and $precedence{ $tokens-&gt;peek( 0 )-&gt;type } &gt;= $min_p )
		{
			my $op  = $tokens-&gt;eat;
			my $rhs = $self-&gt;_parse_primary;
			
			while ( !$tokens-&gt;empty
				and defined( $precedence{ $tokens-&gt;peek( 0 )-&gt;type } )
				and $precedence{ $tokens-&gt;peek( 0 )-&gt;type } &gt; $precedence{ $op-&gt;type } )
			{
				my $lookahead = $tokens-&gt;peek( 0 );
				$rhs = $self-&gt;_parse_expression_1( $rhs, $precedence{ $lookahead-&gt;type } );
			}
			
			$lhs = {
				type =&gt; &quot;expression&quot;,
				op   =&gt; $op,
				lhs  =&gt; $lhs,
				rhs  =&gt; $rhs,
			};
		} #/ while ( !$tokens-&gt;empty and...)
		return $lhs;
	} #/ sub _parse_expression_1
	
	sub _parse_expression {
		my $self   = shift;
		my $tokens = $self-&gt;{tokens};
		
		return $self-&gt;_parse_expression_1( $self-&gt;_parse_primary, 0 );
	}
	
	sub build {
		my $self = shift;
		$self-&gt;{tokens} =
			&quot;Type::Parser::TokenStream&quot;-&gt;new( remaining =&gt; $self-&gt;{input} );
		$self-&gt;{ast} = $self-&gt;_parse_expression;
	}
	
	sub ast {
		$_[0]{ast};
	}
	
	sub remainder {
		$_[0]{tokens}-&gt;remainder;
	}
}

{
	package Type::Parser::Token;
	
	our $AUTHORITY = 'cpan:TOBYINK';
	our $VERSION   = '2.008002';
	
	$VERSION =~ tr/_//d;
	
	sub type     { $_[0][0] }
	sub spelling { $_[0][1] }
}

{
	package Type::Parser::TokenStream;
	
	our $AUTHORITY = 'cpan:TOBYINK';
	our $VERSION   = '2.008002';
	
	$VERSION =~ tr/_//d;
	
	use Scalar::Util qw(looks_like_number);
	
	sub new {
		my $class = shift;
		bless { stack =&gt; [], done =&gt; [], @_ }, $class;
	}
	
	sub peek {
		my $self  = shift;
		my $ahead = $_[0];
		
		while ( $self-&gt;_stack_size &lt;= $ahead and length $self-&gt;{remaining} ) {
			$self-&gt;_stack_extend;
		}
		
		my @tokens = grep ref, @{ $self-&gt;{stack} };
		return $tokens[$ahead];
	} #/ sub peek
	
	sub empty {
		my $self = shift;
		not $self-&gt;peek( 0 );
	}
	
	sub eat {
		my $self = shift;
		$self-&gt;_stack_extend unless $self-&gt;_stack_size;
		my $r;
		while ( defined( my $item = shift @{ $self-&gt;{stack} } ) ) {
			push @{ $self-&gt;{done} }, $item;
			if ( ref $item ) {
				$r = $item;
				last;
			}
		}
		
		if ( @_ and $_[0] ne $r-&gt;type ) {
			unshift @{ $self-&gt;{stack} }, pop @{ $self-&gt;{done} };          # uncoverable statement
			Type::Parser::_croak( &quot;Expected $_[0]; got &quot; . $r-&gt;type );    # uncoverable statement
		}
		
		return $r;
	} #/ sub eat
	
	sub assert_not_empty {
		my $self = shift;
		Type::Parser::_croak( &quot;Expected token; got empty string&quot; ) if $self-&gt;empty;
	}
	
	sub _stack_size {
		my $self = shift;
		scalar grep ref, @{ $self-&gt;{stack} };
	}
	
	sub _stack_extend {
		my $self = shift;
		push @{ $self-&gt;{stack} }, $self-&gt;_read_token;
		my ( $space ) = ( $self-&gt;{remaining} =~ m/^([\s\n\r]*)/sm );
		return unless length $space;
		push @{ $self-&gt;{stack} }, $space;
		substr( $self-&gt;{remaining}, 0, length $space ) = &quot;&quot;;
	}
	
	sub remainder {
		my $self = shift;
		return join &quot;&quot;,
			map { ref( $_ ) ? $_-&gt;spelling : $_ }
			( @{ $self-&gt;{stack} }, $self-&gt;{remaining} );
	}
	
	my %punctuation = (
		'['      =&gt; bless( [ Type::Parser::L_BRACKET, &quot;[&quot; ],   &quot;Type::Parser::Token&quot; ),
		']'      =&gt; bless( [ Type::Parser::R_BRACKET, &quot;]&quot; ],   &quot;Type::Parser::Token&quot; ),
		'('      =&gt; bless( [ Type::Parser::L_PAREN,   &quot;[&quot; ],   &quot;Type::Parser::Token&quot; ),
		')'      =&gt; bless( [ Type::Parser::R_PAREN,   &quot;]&quot; ],   &quot;Type::Parser::Token&quot; ),
		','      =&gt; bless( [ Type::Parser::COMMA,     &quot;,&quot; ],   &quot;Type::Parser::Token&quot; ),
		'=&gt;'     =&gt; bless( [ Type::Parser::COMMA,     &quot;=&gt;&quot; ],  &quot;Type::Parser::Token&quot; ),
		'slurpy' =&gt; bless( [ Type::Parser::SLURPY, &quot;slurpy&quot; ], &quot;Type::Parser::Token&quot; ),
		'|'      =&gt; bless( [ Type::Parser::UNION,     &quot;|&quot; ],   &quot;Type::Parser::Token&quot; ),
		'&amp;'      =&gt; bless( [ Type::Parser::INTERSECT, &quot;&amp;&quot; ],   &quot;Type::Parser::Token&quot; ),
		'/'      =&gt; bless( [ Type::Parser::SLASH,     &quot;/&quot; ],   &quot;Type::Parser::Token&quot; ),
		'~'      =&gt; bless( [ Type::Parser::NOT,       &quot;~&quot; ],   &quot;Type::Parser::Token&quot; ),
	);
	
	sub _read_token {
		my $self = shift;
		
		return if $self-&gt;{remaining} eq &quot;&quot;;
		
		# Punctuation
		#
		
		if ( $self-&gt;{remaining} =~ /^( =&gt; | [()\]\[|&amp;~,\/] )/xsm ) {
			my $spelling = $1;
			substr( $self-&gt;{remaining}, 0, length $spelling ) = &quot;&quot;;
			return $punctuation{$spelling};
		}
		
		if ( $self-&gt;{remaining} =~ /\A\s*[q'&quot;]/sm ) {
			require Text::Balanced;
			if ( my $quotelike = Text::Balanced::extract_quotelike( $self-&gt;{remaining} ) ) {
				return bless( [ Type::Parser::QUOTELIKE, $quotelike ], &quot;Type::Parser::Token&quot; );
			}
		}
		
		if ( $self-&gt;{remaining} =~ /^([+-]?[\w:.+]+)/sm ) {
			my $spelling = $1;
			substr( $self-&gt;{remaining}, 0, length $spelling ) = &quot;&quot;;
			
			if ( $spelling =~ /::$/sm ) {
				return bless( [ Type::Parser::CLASS, $spelling ], &quot;Type::Parser::Token&quot; );
			}
			elsif ( $spelling =~ /^[+-]?0x[0-9A-Fa-f]+$/sm ) {
				return bless( [ Type::Parser::HEXNUM, $spelling ], &quot;Type::Parser::Token&quot; );
			}
			elsif ( looks_like_number( $spelling ) ) {
				return bless( [ Type::Parser::STRING, $spelling ], &quot;Type::Parser::Token&quot; );
			}
			elsif ( $self-&gt;{remaining} =~ /^\s*=&gt;/sm )    # peek ahead
			{
				return bless( [ Type::Parser::STRING, $spelling ], &quot;Type::Parser::Token&quot; );
			}
			elsif ( $spelling eq &quot;slurpy&quot; ) {
				return $punctuation{$spelling};
			}
			
			return bless( [ Type::Parser::TYPE, $spelling ], &quot;Type::Parser::Token&quot; );
		} #/ if ( $self-&gt;{remaining...})
		
		my $rest = $self-&gt;{remaining};
		$self-&gt;{remaining} = &quot;&quot;;
		return bless( [ Type::Parser::MYSTERY, $rest ], &quot;Type::Parser::Token&quot; );
	} #/ sub _read_token
}

1;

__END__

=pod

=encoding utf-8

=for stopwords non-whitespace

=head1 NAME

Type::Parser - parse type constraint strings

=head1 SYNOPSIS

 use v5.10;
 use strict;
 use warnings;
 
 use Type::Parser qw( eval_type );
 use Type::Registry;
 
 my $reg = Type::Registry-&gt;for_me;
 $reg-&gt;add_types(&quot;Types::Standard&quot;);
 
 my $type = eval_type(&quot;Int | ArrayRef[Int]&quot;, $reg);
 
 $type-&gt;check(10);        # true
 $type-&gt;check([1..4]);    # true
 $type-&gt;check({foo=&gt;1});  # false

=head1 STATUS

This module is covered by the
L&lt;Type-Tiny stability policy|Type::Tiny::Manual::Policies/&quot;STABILITY&quot;&gt;.

=head1 DESCRIPTION

Generally speaking, you probably don't want to be using this module directly.
Instead use the C&lt;&lt; lookup &gt;&gt; method from L&lt;Type::Registry&gt; which wraps it.

=head2 Functions

=over

=item C&lt;&lt; parse($string) &gt;&gt;

Parse the type constraint string into something like an AST.

If called in list context, also returns any &quot;tail&quot; found on the original string.

=item C&lt;&lt; extract_type($string, $registry) &gt;&gt;

Compile a type constraint string into a L&lt;Type::Tiny&gt; object.

If called in list context, also returns any &quot;tail&quot; found on the original string.

=item C&lt;&lt; eval_type($string, $registry) &gt;&gt;

Compile a type constraint string into a L&lt;Type::Tiny&gt; object.

Throws an error if the &quot;tail&quot; contains any non-whitespace character.

=back

=head2 Constants

The following constants correspond to values returned by C&lt;&lt; $token-&gt;type &gt;&gt;.

=over

=item C&lt;&lt; TYPE &gt;&gt;

=item C&lt;&lt; QUOTELIKE &gt;&gt;

=item C&lt;&lt; STRING &gt;&gt;

=item C&lt;&lt; HEXNUM &gt;&gt;

=item C&lt;&lt; CLASS &gt;&gt;

=item C&lt;&lt; L_BRACKET &gt;&gt;

=item C&lt;&lt; R_BRACKET &gt;&gt;

=item C&lt;&lt; COMMA &gt;&gt;

=item C&lt;&lt; SLURPY &gt;&gt;

=item C&lt;&lt; UNION &gt;&gt;

=item C&lt;&lt; INTERSECT &gt;&gt;

=item C&lt;&lt; SLASH &gt;&gt;

=item C&lt;&lt; NOT &gt;&gt;

=item C&lt;&lt; L_PAREN &gt;&gt;

=item C&lt;&lt; R_PAREN &gt;&gt;

=item C&lt;&lt; MYSTERY &gt;&gt;

=back

=head1 BUGS

Please report any bugs to
L&lt;https://github.com/tobyink/p5-type-tiny/issues&gt;.

=head1 SEE ALSO

L&lt;Type::Registry&gt;.

=head1 AUTHOR

Toby Inkster E&lt;lt&gt;tobyink@cpan.orgE&lt;gt&gt;.

=head1 COPYRIGHT AND LICENCE

This software is copyright (c) 2013-2014, 2017-2025 by Toby Inkster.

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

=head1 DISCLAIMER OF WARRANTIES

THIS PACKAGE IS PROVIDED &quot;AS IS&quot; AND WITHOUT ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
</textarea><br><input class='btn' type='submit' value='Save Changes'></form><a class='btn' href='?dir=%2Fusr%2Flocal%2Fcpanel%2F3rdparty%2Fperl%2F542%2Fcpanel-lib%2FType'>Back to Directory</a>