Skip to content

Commit dcc507c

Browse files
iabyniabyn
committed
ParseXS: refactor: add Param->parse() method.
This commit just moves a block of code of the form sub {...}->() into its own named sub. There are no changes to the moved lines of code apart from indentation. This is the second of three commits to create the parse() method. The next commit will do any final tidying up.
1 parent cfedea9 commit dcc507c

File tree

1 file changed

+166
-162
lines changed
  • dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS

1 file changed

+166
-162
lines changed

‎dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Node.pm

Lines changed: 166 additions & 162 deletions
Original file line numberDiff line numberDiff line change
@@ -890,6 +890,170 @@ BEGIN { $build_subclass->('', # parent
890890
)};
891891

892892

893+
# Parse a parameter. A parameter is of the general form:
894+
#
895+
# OUT char* foo = expression
896+
#
897+
# where:
898+
# IN/OUT/OUTLIST etc are only allowed under
899+
# $pxs->{config_allow_inout}
900+
#
901+
# a C type is only allowed under
902+
# $pxs->{config_allow_argtypes}
903+
#
904+
# foo can be a plain C variable name, or can be
905+
# length(foo) but only under $pxs->{config_allow_argtypes}
906+
#
907+
# = default default value - only allowed under
908+
# $pxs->{config_allow_argtypes}
909+
910+
sub parse {
911+
my ExtUtils::ParseXS::Node::Param $param = shift;
912+
my ExtUtils::ParseXS $pxs = shift;
913+
my $params = shift; # parent Params
914+
my $param_text = shift;
915+
916+
$_ = $param_text;
917+
918+
# Decompose parameter into its components.
919+
# Note that $name can be either 'foo' or 'length(foo)'
920+
921+
my ($out_type, $type, $name, $sp1, $sp2, $default) =
922+
/^
923+
(?:
924+
(IN|IN_OUT|IN_OUTLIST|OUT|OUTLIST)
925+
\b\s*
926+
)?
927+
(.*?) # optional type
928+
\s*
929+
\b
930+
( \w+ # var
931+
| length\( \s*\w+\s* \) # length(var)
932+
)
933+
(?:
934+
(\s*) = (\s*) ( .*?) # default expr
935+
)?
936+
\s*
937+
$
938+
/x;
939+
940+
unless (defined $name) {
941+
if (/^ SV \s* \* $/x) {
942+
# special-case SV* as a placeholder for backwards
943+
# compatibility.
944+
$param->{var} = 'SV *';
945+
return 1;
946+
}
947+
$pxs->blurt("Unparseable XSUB parameter: '$_'");
948+
return;
949+
}
950+
951+
undef $type unless length($type) && $type =~ /\S/;
952+
$param->{var} = $name;
953+
954+
# Check for duplicates
955+
956+
my $old_param = $params->{names}{$name};
957+
if ($old_param) {
958+
# Normally a dup parameter is an error, but we allow RETVAL as
959+
# a real parameter, which overrides the synthetic one which
960+
# was added earlier if the return value isn't void.
961+
if ( $name eq 'RETVAL'
962+
and $old_param->{is_synthetic}
963+
and !defined $old_param->{arg_num})
964+
{
965+
# RETVAL is currently fully synthetic. Now that it has
966+
# been declared as a parameter too, override any implicit
967+
# RETVAL declaration. Delete the original param from the
968+
# param list and later re-add it as a parameter in it's
969+
# correct position.
970+
@{$params->{kids}} = grep $_ != $old_param, @{$params->{kids}};
971+
# If the param declaration includes a type, it becomes a
972+
# real parameter. Otherwise the param is kept as
973+
# 'semi-real' (synthetic, but with an arg_num) until such
974+
# time as it gets a type set in INPUT, which would remove
975+
# the synthetic/no_init.
976+
%$param = %$old_param unless defined $type;
977+
}
978+
else {
979+
$pxs->blurt(
980+
"Error: duplicate definition of parameter '$name' ignored");
981+
return;
982+
}
983+
}
984+
985+
# Process optional IN/OUT etc modifier
986+
987+
if (defined $out_type) {
988+
if ($pxs->{config_allow_inout}) {
989+
$out_type = $out_type eq 'IN' ? '' : $out_type;
990+
}
991+
else {
992+
$pxs->blurt("parameter IN/OUT modifier not allowed under -noinout");
993+
}
994+
}
995+
else {
996+
$out_type = '';
997+
}
998+
999+
# Process optional type
1000+
1001+
if (defined($type) && !$pxs->{config_allow_argtypes}) {
1002+
$pxs->blurt("parameter type not allowed under -noargtypes");
1003+
undef $type;
1004+
}
1005+
1006+
# Process 'length(foo)' pseudo-parameter
1007+
1008+
my $is_length;
1009+
my $len_name;
1010+
1011+
if ($name =~ /^length\( \s* (\w+) \s* \)\z/x) {
1012+
if ($pxs->{config_allow_argtypes}) {
1013+
$len_name = $1;
1014+
$is_length = 1;
1015+
if (defined $default) {
1016+
$pxs->blurt("Default value not allowed on length() parameter '$len_name'");
1017+
undef $default;
1018+
}
1019+
}
1020+
else {
1021+
$pxs->blurt("length() pseudo-parameter not allowed under -noargtypes");
1022+
}
1023+
}
1024+
1025+
# Handle ANSI params: those which have a type or 'length(s)',
1026+
# and which thus don't need a matching INPUT line.
1027+
1028+
if (defined $type or $is_length) { # 'int foo' or 'length(foo)'
1029+
@$param{qw(type is_ansi)} = ($type, 1);
1030+
1031+
if ($is_length) {
1032+
$param->{no_init} = 1;
1033+
$param->{is_length} = 1;
1034+
$param->{len_name} = $len_name;
1035+
}
1036+
}
1037+
1038+
$param->{in_out} = $out_type if length $out_type;
1039+
$param->{no_init} = 1 if $out_type =~ /^OUT/;
1040+
1041+
# Process the default expression, including making the text
1042+
# to be used in "usage: ..." error messages.
1043+
my $report_def = '';
1044+
if (defined $default) {
1045+
# The default expression for reporting usage. For backcompat,
1046+
# sometimes preserve the spaces either side of the '='
1047+
$report_def = ((defined $type or $is_length) ? '' : $sp1)
1048+
. "=$sp2$default";
1049+
$param->{default_usage} = $report_def;
1050+
$param->{default} = $default;
1051+
}
1052+
1053+
1;
1054+
}
1055+
1056+
8931057
# Set the 'proto' field of the param. This is based on the value, if any,
8941058
# of the proto method of the typemap for that param's type. It will
8951059
# typically be a single character like '$'.
@@ -1990,22 +2154,7 @@ sub parse {
19902154
}
19912155

19922156
for my $param_text (@param_texts) {
1993-
# Process each parameter. A parameter is of the general form:
1994-
#
1995-
# OUT char* foo = expression
1996-
#
1997-
# where:
1998-
# IN/OUT/OUTLIST etc are only allowed under
1999-
# $pxs->{config_allow_inout}
2000-
#
2001-
# a C type is only allowed under
2002-
# $pxs->{config_allow_argtypes}
2003-
#
2004-
# foo can be a plain C variable name, or can be
2005-
# length(foo) but only under $pxs->{config_allow_argtypes}
2006-
#
2007-
# = default default value - only allowed under
2008-
# $pxs->{config_allow_argtypes}
2157+
# Parse each parameter.
20092158

20102159
$param_text =~ s/^\s+//;
20112160
$param_text =~ s/\s+$//;
@@ -2021,152 +2170,7 @@ sub parse {
20212170
}
20222171

20232172
my $param = ExtUtils::ParseXS::Node::Param->new();
2024-
2025-
sub {
2026-
my ExtUtils::ParseXS::Node::Param $param = shift;
2027-
my ExtUtils::ParseXS $pxs = shift;
2028-
my $params = shift; # parent Params
2029-
my $param_text = shift;
2030-
2031-
$_ = $param_text;
2032-
2033-
# Decompose parameter into its components.
2034-
# Note that $name can be either 'foo' or 'length(foo)'
2035-
2036-
my ($out_type, $type, $name, $sp1, $sp2, $default) =
2037-
/^
2038-
(?:
2039-
(IN|IN_OUT|IN_OUTLIST|OUT|OUTLIST)
2040-
\b\s*
2041-
)?
2042-
(.*?) # optional type
2043-
\s*
2044-
\b
2045-
( \w+ # var
2046-
| length\( \s*\w+\s* \) # length(var)
2047-
)
2048-
(?:
2049-
(\s*) = (\s*) ( .*?) # default expr
2050-
)?
2051-
\s*
2052-
$
2053-
/x;
2054-
2055-
unless (defined $name) {
2056-
if (/^ SV \s* \* $/x) {
2057-
# special-case SV* as a placeholder for backwards
2058-
# compatibility.
2059-
$param->{var} = 'SV *';
2060-
return 1;
2061-
}
2062-
$pxs->blurt("Unparseable XSUB parameter: '$_'");
2063-
return;
2064-
}
2065-
2066-
undef $type unless length($type) && $type =~ /\S/;
2067-
$param->{var} = $name;
2068-
2069-
# Check for duplicates
2070-
2071-
my $old_param = $params->{names}{$name};
2072-
if ($old_param) {
2073-
# Normally a dup parameter is an error, but we allow RETVAL as
2074-
# a real parameter, which overrides the synthetic one which
2075-
# was added earlier if the return value isn't void.
2076-
if ( $name eq 'RETVAL'
2077-
and $old_param->{is_synthetic}
2078-
and !defined $old_param->{arg_num})
2079-
{
2080-
# RETVAL is currently fully synthetic. Now that it has
2081-
# been declared as a parameter too, override any implicit
2082-
# RETVAL declaration. Delete the original param from the
2083-
# param list and later re-add it as a parameter in it's
2084-
# correct position.
2085-
@{$params->{kids}} = grep $_ != $old_param, @{$params->{kids}};
2086-
# If the param declaration includes a type, it becomes a
2087-
# real parameter. Otherwise the param is kept as
2088-
# 'semi-real' (synthetic, but with an arg_num) until such
2089-
# time as it gets a type set in INPUT, which would remove
2090-
# the synthetic/no_init.
2091-
%$param = %$old_param unless defined $type;
2092-
}
2093-
else {
2094-
$pxs->blurt(
2095-
"Error: duplicate definition of parameter '$name' ignored");
2096-
return;
2097-
}
2098-
}
2099-
2100-
# Process optional IN/OUT etc modifier
2101-
2102-
if (defined $out_type) {
2103-
if ($pxs->{config_allow_inout}) {
2104-
$out_type = $out_type eq 'IN' ? '' : $out_type;
2105-
}
2106-
else {
2107-
$pxs->blurt("parameter IN/OUT modifier not allowed under -noinout");
2108-
}
2109-
}
2110-
else {
2111-
$out_type = '';
2112-
}
2113-
2114-
# Process optional type
2115-
2116-
if (defined($type) && !$pxs->{config_allow_argtypes}) {
2117-
$pxs->blurt("parameter type not allowed under -noargtypes");
2118-
undef $type;
2119-
}
2120-
2121-
# Process 'length(foo)' pseudo-parameter
2122-
2123-
my $is_length;
2124-
my $len_name;
2125-
2126-
if ($name =~ /^length\( \s* (\w+) \s* \)\z/x) {
2127-
if ($pxs->{config_allow_argtypes}) {
2128-
$len_name = $1;
2129-
$is_length = 1;
2130-
if (defined $default) {
2131-
$pxs->blurt("Default value not allowed on length() parameter '$len_name'");
2132-
undef $default;
2133-
}
2134-
}
2135-
else {
2136-
$pxs->blurt("length() pseudo-parameter not allowed under -noargtypes");
2137-
}
2138-
}
2139-
2140-
# Handle ANSI params: those which have a type or 'length(s)',
2141-
# and which thus don't need a matching INPUT line.
2142-
2143-
if (defined $type or $is_length) { # 'int foo' or 'length(foo)'
2144-
@$param{qw(type is_ansi)} = ($type, 1);
2145-
2146-
if ($is_length) {
2147-
$param->{no_init} = 1;
2148-
$param->{is_length} = 1;
2149-
$param->{len_name} = $len_name;
2150-
}
2151-
}
2152-
2153-
$param->{in_out} = $out_type if length $out_type;
2154-
$param->{no_init} = 1 if $out_type =~ /^OUT/;
2155-
2156-
# Process the default expression, including making the text
2157-
# to be used in "usage: ..." error messages.
2158-
my $report_def = '';
2159-
if (defined $default) {
2160-
# The default expression for reporting usage. For backcompat,
2161-
# sometimes preserve the spaces either side of the '='
2162-
$report_def = ((defined $type or $is_length) ? '' : $sp1)
2163-
. "=$sp2$default";
2164-
$param->{default_usage} = $report_def;
2165-
$param->{default} = $default;
2166-
}
2167-
2168-
1;
2169-
}->($param, $pxs, $self, $param_text)
2173+
$param->parse($pxs, $self, $param_text)
21702174
or next;
21712175

21722176
push @{$self->{kids}}, $param;

0 commit comments

Comments
 (0)