File Coverage

File:	lib/ExtUtils/OOParseXS.pm
Coverage:	64.3%

line	stmt	bran	cond	sub	code
1					package ExtUtils::OOParseXS;
2	12 12 12			12	use strict;
3	12 12 12			12	use warnings;
4
5	12 12 12			12	use 5.006; # We use /??{}/ in regexes
6	12 12 12			12	use Carp;
7	12 12 12			12	use Cwd;
8	12 12 12			12	use Config;
9	12 12 12			12	use Data::Dumper;$Data::Dumper::Indent=1;
10	12 12 12			12	use File::Basename;
11	12 12 12			12	use File::Spec;
12	12 12 12			12	use Symbol;
13					our $VERSION = '2.20_03';
14					our $IN;
15					our $C_arg;
16
17					sub new {
18	38			38	my ($class, $args) = @_;
19	38	100			croak "Missing required parameter 'filename'"
20					unless $args->{filename};
21	36 36				my %args = %{ $args };
22	36				my %data = ();
23	36				$data{ProtoUsed} = exists $args{prototypes};
24	36				my %defaults = (
25					argtypes => 1,
26					csuffix => '.c',
27					hiertype => 0,
28					inout => 1,
29					linenumbers => 1,
30					optimize => 1,
31					output => \*STDOUT,
32					prototypes => 0,
33					typemap => [],
34					versioncheck => 1,
35					);
36					# We start to populate the object's data structure with defaults.
37	36 36				$data{$_} = $defaults{$_} for keys %defaults;
38					# Next, we handle some special cases that may have been provided to the
39					# constructor.
40	36	100			$data{except} = $args{except} ? ' TRY' : '';
41	36				delete $args{except};
42	36	100 100			$data{tm} = ref $args{typemap} ? $args{typemap} :
43					defined( $args{typemap} ) ? [ $args{typemap} ] : [];
44	36				delete $args{typemap};
45					# Finally, we use remaining constructor arguments to overwrite any
46					# corresponding defaults.
47	36 36				$data{$_} = $args{$_} for keys %args;
48
49	36	50			if ($^O eq 'VMS') {
50	0				$data{Is_VMS} = 1;
51					# Establish set of global symbols with max length 28, since xsubpp
52					# will later add the 'XS_' prefix.
53	0				require ExtUtils::XSSymSet;
54	0				$data{SymSet} = ExtUtils::XSSymSet->new(28);
55					}
56	36				$data{XSStack} = [ { type => 'none' } ];
57					# $data{XSS_work_idx} = 0;
58					# $data{cpp_next_tmp} = 'XSubPPtmpAAAA';
59	36				$data{InitFileCode} = [];
60					# # Can we defer assignment to IN until we need to open a read fh?
61					# $data{IN} = Symbol::gensym();
62	36				$data{proto_re} = "[" . quotemeta('\$%&*@;[]') . "]";
63	36				$data{Overload} = 0;
64	36				$data{errors} = 0;
65	36				$data{Fallback} = '&PL_sv_undef';
66
67	36				$data{filepathname} = $data{filename};
68	36				$data{filepathname} =~ s/\\/\\\\/g;
69					# We will use 'base' where previous versions used $filename.
70					# We will reserve 'filename' for the full path of the input file.
71	36				($data{dir}, $data{base}) =
72					( dirname($data{filename}), basename($data{filename}) );
73	36				$data{IncludedFiles}{ $data{filename} }++;
74	36				$data{name} = undef;
75					# No reason to open either the input file or the output stream/file just
76					# yet. We'll create a scalar and push matter to be printed onto it.
77	36				$data{out} = q{};
78
79	36	100			if ($data{linenumbers}) {
80	29	100			if ( ! ref( $data{output} ) ) {
81	24				$data{cfile} = $data{output};
82					}
83					else {
84	5				$data{cfile} = $data{base};
85	5	100			$data{cfile} =~ s/\.xs$/$data{csuffix}/i
86					or $data{cfile} .= $data{csuffix};
87					}
88					}
89
90					# Really, we shouldn't have to chdir() or select() in the first
91					# place. For now, just save & restore.
92	36				$data{orig_cwd} = cwd();
93	36				$data{orig_fh} = select();
94
95	36				chdir($data{dir});
96	36				$data{pwd} = cwd();
97
98	36				my $obj = bless \%data, $class;
99	36				return $obj;
100					}
101
102					sub determine_typemaps {
103	22			22	my ($self) = @_;
104	22		50		my $testing_typemap = shift \|\| undef;
105
106	22 22				foreach my $typemap (@{ $self->{tm} }) {
107	21	100			croak "Can't find $typemap in $self->{pwd}\n" unless -r $typemap;
108					}
109
110	21 21				push @{ $self->{tm} }, standard_typemap_locations($testing_typemap);
111	21				$self->{type_kind} = {};
112	21				$self->{proto_letter} = {};
113	21				$self->{input_expr} = {};
114	21				$self->{output_expr} = {};
115
116	21				ALL_TYPEMAPS:
117	21				foreach my $typemap (@{ $self->{tm} }) {
118	251	100			next unless -f $typemap;
119					# skip directories, binary files etc.
120	41	100			unless ( -T $typemap ) {
121	1				carp("Warning: ignoring non-text typemap file '$typemap'\n");
122	1				next;
123					}
124	40	50			open my $TYPEMAP, '<', $typemap
125					or carp ("Warning: could not open typemap file '$typemap': $!\n"),
126					next;
127	40				my $mode = 'Typemap';
128	40				my $junk = "";
129	40				my $current = \$junk;
130					EACH_TYPEMAP:
131	40				while (<$TYPEMAP>) {
132	13459	100			next if /^\s*#/;
133	13299	100			if (/^INPUT\s*$/) {
134	40 40 40				$mode = 'Input'; $current = \$junk; next;
135					}
136	13259	100			if (/^OUTPUT\s*$/) {
137	40 40 40				$mode = 'Output'; $current = \$junk; next;
138					}
139	13219	100			if (/^TYPEMAP\s*$/) {
140	19 19 19				$mode = 'Typemap'; $current = \$junk; next;
141					}
142	13200	100 100 100			if ($mode eq 'Typemap') {
143	2120				chomp;
144	2120				my $raw_line = $_;
145	2120				TrimWhitespace($_);
146					# Skip completely empty lines -- having skipped comments above
147					# -- but why not all lines consisting solely of whitespace?
148					# I'm going to change that.
149					# next if /^$/;
150	2120	100			next if /^\s*$/;
151	2040	100			my ($type, $kind, $proto) =
152					/^\s(.?\S)\s+(\S+)\s($self->{proto_re})\s*$/
153					or carp("Warning: File '$typemap' Line $. '$raw_line' TYPEMAP entry needs 2 or 3 columns\n"), next;
154	2039				$type = TidyType($type);
155	2039				$self->{type_kind}{$type} = $kind;
156					# Need to find examples of typemaps that have a 3rd column.
157					# prototype defaults to '$'.
158	2039	50			$proto = "\$" unless $proto;
159					# Need to create test that exercises next line.
160	2039	50			carp "Warning: File '$typemap' Line $. '$raw_line' Invalid prototype '$proto'\n"
161					unless $self->ValidProtoString($proto);
162	2039				$self->{proto_letter}{$type} = C_string($proto);
163					}
164					elsif (/^\s/) {
165	7840				$$current .= $_;
166					}
167					elsif ($mode eq 'Input') {
168	1600				s/\s+$//;
169	1600				$self->{input_expr}{$_} = '';
170	1600				$current = \$self->{input_expr}{$_};
171					}
172					else {
173	1640				s/\s+$//;
174	1640				$self->{output_expr}{$_} = '';
175	1640				$current = \$self->{output_expr}{$_};
176					}
177					} # End EACH_TYPEMAP
178	40	50			close $TYPEMAP
179					or carp "Unable to close handle to $typemap after reading: $!";
180					} # End ALL_TYPEMAPS
181	21				return 1;
182					}
183
184					sub align_to_first_column {
185	17			17	my ($self) = @_;
186	17 17				foreach my $value (values %{ $self->{input_expr} }) {
187	680				$value =~ s/;*\s+\z//;
188					# Move C pre-processor instructions to column 1 to be strictly ANSI
189					# conformant. Some pre-processors are fussy about this.
190	680				$value =~ s/^\s+#/#/mg;
191					}
192	17 17				foreach my $value (values %{ $self->{output_expr} }) {
193					# And again.
194	697				$value =~ s/^\s+#/#/mg;
195					}
196	17				return 1;
197					}
198
199					sub prepare_patterns {
200	16			16	my ($self) = @_;
201	16				our $bal;
202	16				$bal = qr[(?:(?>[^()]+)\|$(??{ $bal })$)*]; # ()-balanced
203	16				$self->{cast} = qr[(?:$\sSV\s\\s$\s)?]; # Optional (SV) cast
204	16				$self->{size} = qr[,\s* (??{ $bal }) ]x; # Third arg (to setpvn)
205	16				$self->{bal} = $bal;
206					}
207
208					sub targetable {
209	15			15	my ($self) = @_;
210	15				$self->{targetable} = {};
211
212	15 15				foreach my $key (keys %{ $self->{output_expr} }) {
213	12			12	BEGIN { $^H \|= 0x00200000 }; # Equivalent to: use re 'eval', but hardcoded so we can compile re.xs
214
215	615				my ($t, $with_size, $arg, $sarg) =
216					($self->{output_expr}{$key} =~
217					m[^ \s+ sv_set ( [iunp] ) v (n)? # Type, is_setpvn
218					\s* \( \s* $self->{cast} \$arg \s* ,
219					\s* ( (??{ $self->{bal} }) ) # Set from
220					( (??{ $self->{size} }) )? # Possible sizeof set-from
221					\) \s* ; \s* $
222					]x);
223	615	100			$self->{targetable}{$key} = [$t, $with_size, $arg, $sarg] if $t;
224					}
225
226	15				$self->{END} = "!End!\n\n"; # "impossible" keyword (multiple newline)
227
228					# Match an XS keyword
229	15				$self->{BLOCK_re} = '\s*(' . join('\|', qw(
230					REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT
231					CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE
232					SCOPE INTERFACE INTERFACE_MACRO C_ARGS POSTCALL OVERLOAD FALLBACK
233					) ) . "\|$self->{END})\\s*:";
234					}
235
236					sub group_chunk_c {
237	14			14	my ($self) = @_;
238					# Group in C (no support for comments or literals)
239	14				our $C_group_rex;
240	14				$C_group_rex = qr/ [({\[]
241					(?: (?> [^()\[\]{}]+ ) \| (??{ $C_group_rex }) )*
242					[)}\]] /x;
243					# Chunk in C without comma at toplevel (no comments):
244					# $self->{C_arg} = qr/ (?: (?> [^()\[\]{},"']+ )
245	14				$C_arg = qr/ (?: (?> [^()\[\]{},"']+ )
246					\| (??{ $C_group_rex })
247					\| " (?: (?> [^\\"]+ )
248					\| \\.
249					)* " # String literal
250					\| ' (?: (?> [^\\']+ ) \| \\. )* ' # Char literal
251					)* /xs;
252	14				$self->{C_group_rex} = $C_group_rex;
253					}
254
255					sub output_header {
256	13			13	my ($self) = @_;
257					# Identify the version of xsubpp used
258	13				$self->{out} .= <<"EOM";
259					/*
260					* This file was generated automatically by ExtUtils::ParseXS version $VERSION from the
261					* contents of $self->{base}. Do not edit this file, edit $self->{base} instead.
262					*
263					* ANY CHANGES MADE HERE WILL BE LOST!
264					*
265					*/
266
267					EOM
268
269	13	100			$self->{out} .= ("#line 1 \"$self->{filepathname}\"\n")
270					if $self->{linenumbers};
271	13				return 1;
272					}
273
274					sub open_input_file {
275	11			11	my ($self) = @_;
276	11				$self->{lastline} = undef;
277	11				$self->{Package} = undef;
278	11				$self->{Prefix} = undef;
279	11				$IN = Symbol::gensym();
280	11	50			open $IN, '<', $self->{base}
281					or croak "Unable to open $self->{base} for parsing: $!";
282					FIRSTMODULE:
283	11				while (<$IN>) {
284	257	100			if (/^=/) {
285	3				my $podstartline = $.;
286	3				do {
287	15	100			if (/^=cut\s*$/) {
288					# We can't just write out a /* */ comment, as our embedded
289					# POD might itself be in a comment. We can't put a /**/
290					# comment inside #if 0, as the C standard says that the
291					# source file is decomposed into preprocessing characters
292					# in the stage before preprocessing commands are executed.
293					# I don't want to leave the text as barewords, because the
294					# spec isn't clear whether macros are expanded before or
295					# after preprocessing commands are executed, and someone
296					# pathological may just have defined one of the 3 words as
297					# a macro that does something strange. Multiline strings
298					# are illegal in C, so the "" we write must be a string
299					# literal. And they aren't concatenated until 2 steps
300					# later, so we are safe. - Nicholas Clark
301	3				$self->{out} .=
302					qq\|#if 0\n "Skipped embedded POD."\n#endif\n\|;
303	3	100			$self->{out} .=
304					sprintf(qq\|#line %d "$self->{filepathname}"\n\|, $. + 1)
305					if $self->{linenumbers};
306	3				next FIRSTMODULE;
307					}
308					} while (<$IN>);
309					# At this point $. is at end of file so die won't state the start
310					# of the problem, and as we haven't yet read any lines &death won't
311					# show the correct line in the message either.
312	0	0			die ("Error: Unterminated pod in $self->{filename}, line $podstartline\n")
313					unless $self->{lastline};
314					}
315	254	100			last if ($self->{Package}, $self->{Prefix}) =
316					/^MODULE\s=\s[\w:]+(?:\s+PACKAGE\s=\s([\w:]+))?(?:\s+PREFIX\s=\s(\S+))?\s*$/;
317
318	244				$self->{out} .= $_;
319					}
320	11	100			unless (defined $_) {
321	1				warn "Didn't find a 'MODULE ... PACKAGE ... PREFIX' line\n";
322					# exit 0; # Not a fatal error for the caller process
323					# But we shouldn't 'exit 0' from deep within a subroutine as that
324					# causes our test files to terminate prematurely. Instead,
325					# the caller should check the sub's return value for definedness and
326					# exit if not defined. -- jk Aug 09 2009.
327	1				return;
328					}
329
330	10	100			$self->{out} .= qq{#line --- "$self->{cfile}"}
331					if $self->{linenumbers};
332	10				return $IN;
333					}
334
335					sub croak_xs_usage {
336	6			6	my ($self) = @_;
337
338	6				$self->{out} .= <<"EOF";
339					#ifndef PERL_UNUSED_VAR
340					# define PERL_UNUSED_VAR(var) if (0) var = var
341					#endif
342
343					EOF
344
345	6				$self->{out} .= <<"EOF";
346					#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
347					#define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
348
349					/* prototype to pass -Wmissing-prototypes */
350					STATIC void
351					S_croak_xs_usage(pTHX_ const CV const cv, const char const params);
352
353					STATIC void
354					S_croak_xs_usage(pTHX_ const CV const cv, const char const params)
355					{
356					const GV *const gv = CvGV(cv);
357
358					PERL_ARGS_ASSERT_CROAK_XS_USAGE;
359
360					if (gv) {
361					const char *const gvname = GvNAME(gv);
362					const HV *const stash = GvSTASH(gv);
363					const char *const hvname = stash ? HvNAME(stash) : NULL;
364
365					if (hvname)
366					Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
367					else
368					Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
369					} else {
370					/* Pants. I don't think that it should be possible to get here. */
371					Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
372					}
373					}
374					#undef PERL_ARGS_ASSERT_CROAK_XS_USAGE
375
376					#ifdef PERL_IMPLICIT_CONTEXT
377					#define croak_xs_usage(a,b) S_croak_xs_usage(aTHX_ a,b)
378					#else
379					#define croak_xs_usage S_croak_xs_usage
380					#endif
381
382					#endif
383
384					EOF
385
386	6	100			$self->{out} .= qq{#line --- "$self->{cfile}"}
387					if $self->{linenumbers};
388	6				$self->{lastline} = $_;
389	6				$self->{lastline_no} = $.;
390	6				return 1;
391					}
392
393					# Per Uri: print rarely and late. There is no reason to worry about opening
394					# the output filehandle until we absolutely need to. Let's accumulate the
395					# string we'll print and do a single print call at end of process.
396					sub open_output_filehandles {
397	5			5	my ($self) = @_;
398					# Open the output file if given as a string. If they provide some
399					# other kind of reference, trust them that we can print to it.
400	5	100			if (not ref $self->{output}) {
401					# i.e., if an output file was specified
402	2	50			open my $fh_out, '>', $self->{output}
403					or croak "Can't create $self->{output}: $!";
404	2				$self->{outfile} = $self->{output};
405	2				$self->{output} = $fh_out;
406					}
407
408	5	100			if ($self->{linenumbers}) {
409	3	100			if ( $self->{outfile} ) {
410	1				$self->{cfile} = $self->{outfile};
411					}
412					else {
413	2				$self->{cfile} = $self->{base};
414	2	100			$self->{cfile} =~ s/\.xs$/$self->{csuffix}/i
415					or $self->{cfile} .= $self->{csuffix};
416					}
417	3				tie(*PSEUDO_STDOUT, 'ExtUtils::OOParseXS::CountLines',
418					$self->{cfile},
419					$self->{output}
420					);
421	3				select PSEUDO_STDOUT;
422					}
423					else {
424	2				select $self->{output};
425					}
426					}
427
428					sub sixhundredpoundgorilla {
429	2			2	my ($self) = @_;
430	2				$self->{XSS_work_idx} = 0;
431	2				$self->{cpp_next_tmp} = 'XSubPPtmpAAAA';
432	2				$self->{line} = [];
433	2				$self->{line_no} = [];
434
435	2				my @BootCode;
436	2				my @outlist;
437	2				my $prepush_done;
438	2				my $rvref = [];
439					PARAGRAPH:
440	2		67		until ($rvref = $self->fetch_para() and $rvref->[0] == 0) {
441	27 27 27				@{ $self->{line} } = @{ $rvref->[0] };
442	27 27 27				@{ $self->{line_no} } = @{ $rvref->[1] };
443	27				my $xsreturn;
444					# Print initial preprocessor statements and blank lines
445					# while (@{ $self->{line} } && $self->{line}->[0] !~ /^[^\#]/) {
446	27 30		100		while (@{ $self->{line} } && $self->{line}->[0] =~ /^(?:#\|$)/) {
447	3 3				my $l = shift(@{ $self->{line} });
448					# print $l, "\n";
449	3				$self->{out} .= $l;
450	3	100			next unless $l =~ /^\#\s*((if)(?:n?def)?\|elsif\|else\|endif)\b/;
451	1				my $statement = $+;
452	1	50			if ($statement eq 'if') {
453					# $XSS_work_idx = @XSStack;
454					# push(@XSStack, {type => 'if'});
455	1 1				$self->{XSS_work_idx} = scalar @{ $self->{XSStack} };
456	1 1				push(@{ $self->{XSStack} }, {type => 'if'});
457					}
458					else {
459					# death ("Error: `$statement' with no matching `if'")
460					# if $XSStack[-1]{type} ne 'if';
461	0	0			croak "Error: '$statement' with no matching 'if'"
462					if $self->{XSStack}->[-1]{type} ne 'if';
463	0	0			if ($self->{XSStack}->[-1]{varname}) {
464	0 0				push @{ $self->{InitFileCode} }, "#endif\n";
465	0				push @BootCode, "#endif";
466					}
467
468	0 0				my(@fns) = keys %{ $self->{XSStack}->[-1]{functions} };
469	0	0			if ($statement ne 'endif') {
470					# Hide the functions defined in other #if branches,
471					# and reset.
472	0 0				@{ $self->{XSStack}->[-1]{other_functions}}{@fns} =
473					(1) x @fns;
474	0 0				@{ $self->{XSStack}->[-1]}{qw(varname functions)} =
475					('', {});
476					}
477					else {
478	0 0				my($tmp) = pop(@{ $self->{XSStack} });
479	0		0		0 while (--$self->{XSS_work_idx}
480					&& $self->{XSStack}[$self->{XSS_work_idx}]{type} ne 'if');
481					# Keep all new defined functions
482	0 0				push(@fns, keys %{$tmp->{other_functions}});
483	0 0				@{ $self->{XSStack}->[$self->{XSS_work_idx}]{functions}}{@fns} = (1) x @fns;
484					}
485					}
486					}
487
488	27 27	100			next PARAGRAPH unless @{ $self->{line} };
489	22	100	100		if ($self->{XSS_work_idx} &&
490					! $self->{XSStack}[$self->{XSS_work_idx}]{varname}) {
491					# We are inside an #if, but have not yet #defined its xsubpp variable.
492					# print "#define $self->{cpp_next_tmp} 1\n\n";
493	1				$self->{out} .= "#define $self->{cpp_next_tmp} 1\n\n";
494	1 1				push @{ $self->{InitFileCode} }, "#if $self->{cpp_next_tmp}\n";
495	1				push @BootCode, "#if $self->{cpp_next_tmp}";
496	1				$self->{XSStack}[$self->{XSS_work_idx}]{varname} =
497					$self->{cpp_next_tmp}++;
498					}
499	22	50			croak "Code is not inside a function"
500					. " (maybe last function was ended by a blank line "
501					. " followed by a statement on column one?): $!"
502					if $self->{line}->[0] =~ /^\s/;
503
504	22				my ($class, $externC, $static, $ellipsis, $wantRETVAL, $RETVAL_no_return);
505	22				my (@fake_INPUT_pre); # For length(s) generated variables
506	22				my (@fake_INPUT);
507
508					# initialize info variables
509					# we can defer initialization of arg_list
510					# $self->{arg_list} = {};
511	22				$self->{args_match} = {};
512	22				$self->{argtype_seen} = {};
513	22				$self->{defaults} = {};
514	22				$self->{in_out} = {};
515	22				$self->{lengthof} = {};
516	22				$self->{var_types} = {};
517
518	22				$self->{outlist} = [];
519	22				$self->{proto_arg} = [];
520
521	22				$self->{interface} = undef;
522	22				$self->{prepush_done} = undef;
523	22				$self->{processing_arg_with_types} = undef;
524	22				$self->{proto_in_this_xsub} = undef;
525	22				$self->{scope_in_this_xsub} = undef;
526	22				$self->{interface_macro} = 'XSINTERFACE_FUNC';
527	22				$self->{interface_macro_set} = 'XSINTERFACE_FUNC_SET';
528
529					# $ProtoThisXSUB = $WantPrototypes;
530	22				$self->{ProtoThisXSUB} = $self->{prototypes};
531	22				$self->{ScopeThisXSUB} = 0;
532	22				$xsreturn = 0;
533
534	22 22				my $thisline = shift(@{ $self->{line} });
535	22				my $kwd = '';
536	22		67		while ( ( ( $kwd, $thisline ) = $self->check_keyword(
537					$thisline,
538					"REQUIRE\|PROTOTYPES\|FALLBACK\|VERSIONCHECK\|INCLUDE",
539					) ) and $kwd ) {
540					# Next 2 lines need work: conversion to OO.
541	12 12 12			12	no strict 'refs';
542	6 6				$thisline = &{"${kwd}_handler"}( $self, $thisline );
543	6 6	50			next PARAGRAPH unless @{ $self->{line} };
544	0 0				$thisline = shift(@{ $self->{line} });
545					}
546
547	16	100	67		if ( ( ($kwd, $thisline) = $self->check_keyword($thisline, 'BOOT') )
548					and $kwd ) {
549	1				$self->check_cpp();
550	1 1				push @BootCode, "#line $self->{line_no}->[@{ $self->{line_no} }
551	1	50	33		- @{ $self->{line} }] \"$self->{filepathname}\""
552					if $self->{linenumbers} && $self->{line}->[0] !~ /^\s#\sline\b/;
553	1 1				push @BootCode, ( @{ $self->{line} }, "" );
554	1				next PARAGRAPH;
555					}
556
557					# extract return type, function name and arguments
558	15				$self->{ret_type} = TidyType($thisline);
559	15	50			$RETVAL_no_return = 1 if $self->{ret_type} =~ s/^NO_OUTPUT\s+//;
560
561					# Allow one-line ANSI-like declaration
562					# $process_argtypes replaced by $self->{argtypes}
563					# unshift @line, $2
564					# if $process_argtypes
565					# and $ret_type =~ s/^(.?\w.?)\s\b(\w+\s\(.*)/$1/s;
566	15	50	33		if ( $self->{argtypes} and
567					$self->{ret_type} =~ s/^(.?\w.?)\s\b(\w+\s\(.*)/$1/s
568					) {
569	0 0				unshift @{ $self->{line} }, $2;
570					}
571
572					# a function definition needs at least 2 lines
573	15 15	100			unless (@{ $self->{line} }) {
574	1				carp "Error: Function definition too short '$self->{ret_type}': $!";
575	1				$self->{errors}++;
576	1				next PARAGRAPH;
577					}
578	14	50			$externC = 1 if $self->{ret_type} =~ s/^extern "C"\s+//;
579	14	50			$static = 1 if $self->{ret_type} =~ s/^static\s+//;
580
581	14 14				my $func_header = shift(@{ $self->{line} });
582	14	50			unless ($func_header =~
583					/^(?:([\w:])::)?(\w+)\s$\s(.?)\s$\s(const)?\s(;\s)?$/s) {
584	0				carp "Error: Cannot parse function definition from '$func_header': $!" ;
585	0				$self->{errors}++;
586	0				next PARAGRAPH;
587					}
588	14				my $orig_args;
589	14				($class, $self->{func_name}, $orig_args) = ($1, $2, $3);
590	14	50			$class = "$4 $class" if $4;
591	14				($self->{pname} = $self->{func_name}) =~
592					s/^($self->{Prefix})?/$self->{Packprefix}/;
593	14				my $clean_func_name;
594	14				($clean_func_name = $self->{func_name}) =~ s/^$self->{Prefix}//;
595	14				$self->{Full_func_name} = "$self->{Packid}_$clean_func_name";
596	14	50			if ($self->{Is_VMS}) {
597	0				$self->{Full_func_name} =
598					$self->{SymSet}->addsym($self->{Full_func_name});
599					}
600
601					# Check for duplicate function definition
602	14 14				for my $tmp ( @{ $self->{XSStack} } ) {
603	16	50			next unless defined $tmp->{functions}{$self->{Full_func_name}};
604	0				$self->warnline("Warning: duplicate function definition '$clean_func_name' detected");
605	0				last;
606					}
607	14				$self->{XSStack}->[$self->{XSS_work_idx}]{functions}{$self->{Full_func_name}}++;
608	14				$self->{XsubAliases} = {};
609	14				$self->{XsubAliasValues} = {};
610	14				$self->{Interfaces} = {};
611	14				$self->{Attributes} = [];
612	14				$self->{DoSetMagic} = 1;
613
614	14				$orig_args =~ s/\\\s*/ /g; # process line continuations
615	14				my @args;
616
617	14				my %only_C_inlist; # Not in the signature of Perl function
618					# if ($process_argtypes and $orig_args =~ /\S/) {
619	14	100	67		if ($self->{argtypes} and $orig_args =~ /\S/) {
620	11				my $args = "$orig_args ,";
621	11	50			if ($args =~ /^( (??{ $C_arg }) , )* $ /x) {
622	11				@args = ($args =~ /\G ( (??{ $C_arg }) ) , /xg);
623	11				for my $thisarg ( @args ) {
624	16				$thisarg =~ s/^\s+//;
625	16				$thisarg =~ s/\s+$//;
626	16				my ($arg, $default) =
627					( $thisarg =~ / ( [^=]* ) ( (?: = .*)? ) /x );
628	16				my ($pre, $name) = ($arg =~ /(.?) \s
629					\b ( \w+ \| length$ \s\w+\s $ )
630					\s* $ /x);
631	16	100	100		next unless defined($pre) && length($pre);
632	5				my $out_type = '';
633	5				my $inout_var;
634					# $process_inout replaced by $self->{inout}
635	5	50	33		if ($self->{inout} and s/^(IN\|IN_OUTLIST\|OUTLIST\|OUT\|IN_OUT)\s+//) {
636	0				my $type = $1;
637	0	0			$out_type = $type if $type ne 'IN';
638	0				$arg =~ s/^(IN\|IN_OUTLIST\|OUTLIST\|OUT\|IN_OUT)\s+//;
639	0				$pre =~ s/^(IN\|IN_OUTLIST\|OUTLIST\|OUT\|IN_OUT)\s+//;
640					}
641	5				my $islength;
642	5	100			if ($name =~ /^length$ \s* (\w+) \s* $\z/x) {
643	1				$name = "XSauto_length_of_$1";
644	1				$islength = 1;
645	1	50			croak "Default value on length() argument: '$thisarg': $!"
646					if length $default;
647					}
648	5	50	33		if (length $pre or $islength) { # Has a type
649	5	100			if ($islength) {
650	1				push @fake_INPUT_pre, $arg;
651					}
652					else {
653	4				push @fake_INPUT, $arg;
654					}
655					# warn "pushing '$arg'\n";
656	5				$self->{argtype_seen}{$name}++;
657	5				$thisarg = "$name$default"; # Assigns to @args
658					}
659	5	100	67		$only_C_inlist{$thisarg} = 1
660					if $out_type eq "OUTLIST" or $islength;
661	5 0	50			push @{ $self->{outlist} }, $name if $out_type =~ /OUTLIST$/;
662	5	50			$self->{in_out}{$name} = $out_type if $out_type;
663					}
664					}
665					else {
666	0				@args = split(/\s,\s/, $orig_args);
667	0				$self->warnline("Warning: cannot parse argument list '$orig_args', fallback to split: $!");
668					}
669					}
670					else {
671	3				@args = split(/\s,\s/, $orig_args);
672	3				for my $thisarg (@args) {
673					# if ($process_inout and s/^(IN\|IN_OUTLIST\|OUTLIST\|IN_OUT\|OUT)\s+//) {
674	0	0	0		if ($self->{inout} and $thisarg =~ s/^(IN\|IN_OUTLIST\|OUTLIST\|IN_OUT\|OUT)\s+//) {
675	0				my $out_type = $1;
676	0	0			next if $out_type eq 'IN';
677	0	0			$only_C_inlist{$thisarg} = 1 if $out_type eq "OUTLIST";
678					# $name 2 lines below seems out of scope -- jk 20090731
679					# my $name; # keep 'use strict' happy
680					# push @{ $self->{outlist} }, $name if $out_type =~ /OUTLIST$/;
681	0 0	0			push @{ $self->{outlist} }, $self->{name}
682					if $out_type =~ /OUTLIST$/;
683	0				$self->{in_out}{$thisarg} = $out_type;
684					}
685					}
686					}
687	14	50			if (defined($class)) {
688	0	0	0		my $arg0 = ( defined($static) or $self->{func_name} eq 'new' )
689					? "CLASS" : "THIS";
690	0				unshift(@args, $arg0);
691					}
692	14				my $extra_args = 0;
693	14				my @args_num = ();
694	14				my $num_args = 0;
695	14				my $report_args = '';
696	14				foreach my $i (0 .. $#args) {
697	16	100			if ($args[$i] =~ s/\.\.\.//) {
698	2				$ellipsis = 1;
699	2	50	33		if ($args[$i] eq '' && $i == $#args) {
700	2				$report_args .= ", ...";
701	2				pop(@args);
702	2				last;
703					}
704					}
705	14	100			if ($only_C_inlist{$args[$i]}) {
706	1				push @args_num, undef;
707					}
708					else {
709	13				push @args_num, ++$num_args;
710	13				$report_args .= ", $args[$i]";
711					}
712	14	50			if ($args[$i] =~ /^([^=][^\s=])\s=\s(.)/s) {
713	0				$extra_args++;
714	0				$args[$i] = $1;
715	0				$self->{defaults}->{$args[$i]} = $2;
716	0				$self->{defaults}->{$args[$i]} =~ s/"/\\"/g;
717					}
718	14				$self->{proto_arg}->[$i+1] = '$';
719					}
720	14				my $min_args = $num_args - $extra_args;
721	14				$report_args =~ s/"/\\"/g;
722	14				$report_args =~ s/^,\s+//;
723	14				my @func_args = @args;
724	14	50			shift @func_args if defined($class);
725
726	14				for my $fa (@func_args) {
727	14	50			s/^/&/ if $self->{in_out}->{$fa};
728					}
729	14				$self->{func_args} = join(", ", @func_args);
730	14 14				@{ $self->{args_match} }{@args} = @args_num;
731
732	14 14				my $PPCODE = grep(/^\sPPCODE\s:/, @{ $self->{line} });
733	14 14				my $CODE = grep(/^\sCODE\s:/, @{ $self->{line} });
734					# Detect CODE: blocks which use ST(n)= or XST_m*(n,v)
735					# to set explicit return values.
736	9				my $EXPLICIT_RETURN = ($CODE &&
737	14		67		("@{ $self->{line} }" =~ /(\bST\s\([^;]=) \| (\bXST_m\w+\s*\()/x ));
738	14 14				my $ALIAS = grep(/^\sALIAS\s:/, @{ $self->{line} });
739	14 14				my $INTERFACE = grep(/^\sINTERFACE\s:/, @{ $self->{line} });
740
741	14	50			$xsreturn = 1 if $EXPLICIT_RETURN;
742
743	14	50			$externC = $externC ? qq[extern "C"] : "";
744
745					# print function header
746	14				$self->{out} .= Q(<<"EOF");
747					#$externC
748					#XS(XS_$self->{Full_func_name}); /* prototype to pass -Wmissing-prototypes */
749					#XS(XS_$self->{Full_func_name})
750					#[[
751					##ifdef dVAR
752					# dVAR; dXSARGS;
753					##else
754					# dXSARGS;
755					##endif
756					EOF
757	14	100			$self->{out} .= Q(<<"EOF") if $ALIAS;
758					# dXSI32;
759					EOF
760	14	50			$self->{out} .= Q(<<"EOF") if $INTERFACE;
761					# dXSFUNCTION($self->{ret_type});
762					EOF
763	14	100 50			if ($ellipsis) {
764	2	100			$self->{cond} = ($min_args ? qq(items < $min_args) : 0);
765					}
766					elsif ($min_args == $num_args) {
767	12				$self->{cond} = qq(items != $min_args);
768					}
769					else {
770	0				$self->{cond} = qq(items < $min_args \|\| items > $num_args);
771					}
772
773	14	50			$self->{out} .= Q(<<"EOF") if $self->{except};
774					# char errbuf[1024];
775					# *errbuf = '\0';
776					EOF
777
778	14	100			if($self->{cond}) {
779	13				$self->{out} .= Q(<<"EOF");
780					# if ($self->{cond})
781					# croak_xs_usage(cv, "$report_args");
782					EOF
783					}
784					else {
785					# cv likely to be unused
786	1				$self->{out} .= Q(<<"EOF");
787					# PERL_UNUSED_VAR(cv); /* -W */
788					EOF
789					}
790
791					#gcc -Wall: if an xsub has PPCODE is used
792					#it is possible none of ST, XSRETURN or XSprePUSH macros are used
793					#hence `ax' (setup by dXSARGS) is unused
794					#XXX: could breakup the dXSARGS; into dSP;dMARK;dITEMS
795					#but such a move could break third-party extensions
796	14	100			$self->{out} .= Q(<<"EOF") if $PPCODE;
797					# PERL_UNUSED_VAR(ax); /* -Wall */
798					EOF
799
800	14	100			$self->{out} .= Q(<<"EOF") if $PPCODE;
801					# SP -= items;
802					EOF
803
804					# Now do a block of some sort.
805
806	14				$self->{condnum} = 0;
807	14				$self->{cond} = ''; # last CASE: condidional
808	14 14				push(@{ $self->{line} }, "$self->{END}:");
809	14 14				push(@{ $self->{line_no} }, $self->{line_no}->[-1]);
810					# $_ = '';
811	14				$thisline = '';
812	14				$self->check_cpp();
813					# TESTING CHALLENGE: Until suitable refined, this 'while' loop is
814					# infinite, causing t/016 to hang.
815	14 28				while (@{ $self->{line} }) {
816					## &CASE_handler if check_keyword("CASE");
817	14	100	67		if ( ( ($kwd, $thisline) = $self->check_keyword($thisline, 'CASE') )
818					and $kwd ) {
819	1				$thisline = $self->CASE_handler($thisline);
820					}
821	14				$self->{out} .= Q(<<"EOF");
822					# $self->{except} [[
823					EOF
824
825					# do initialization of input variables
826	14				$self->{thisdone} = 0;
827	14				$self->{retvaldone} = 0;
828	14				$self->{deferred} = '';
829	14				$self->{arg_list} = {};
830	14				$self->{gotRETVAL} = 0;
831
832					# INPUT_handler();
833					# process_keyword("INPUT\|PREINIT\|INTERFACE_MACRO\|C_ARGS\|ALIAS\|ATTRS\|PROTOTYPE\|SCOPE\|OVERLOAD");
834					#
835					# print Q(<<"EOF") if $ScopeThisXSUB;
836					## ENTER;
837					## [[
838					#EOF
839					#
840					# if (!$thisdone && defined($class)) {
841					# if (defined($static) or $func_name eq 'new') {
842					# print "\tchar *";
843					# $var_types{"CLASS"} = "char *";
844					# &generate_init("char *", 1, "CLASS");
845					# }
846					# else {
847					# print "\t$class *";
848					# $var_types{"THIS"} = "$class *";
849					# &generate_init("$class *", 1, "THIS");
850					# }
851					# }
852					#
853					# # do code
854					# if (/^\s*NOT_IMPLEMENTED_YET/) {
855					# print "\n\tPerl_croak(aTHX_ \"$pname: not implemented yet\");\n";
856					# $_ = '';
857					# }
858					# else {
859					# if ($ret_type ne "void") {
860					# print "\t" . &map_type($ret_type, 'RETVAL') . ";\n"
861					# if !$retvaldone;
862					# $args_match{"RETVAL"} = 0;
863					# $var_types{"RETVAL"} = $ret_type;
864					# print "\tdXSTARG;\n"
865					# if $WantOptimize and $targetable{$type_kind{$ret_type}};
866					# }
867					#
868					# if (@fake_INPUT or @fake_INPUT_pre) {
869					# unshift @line, @fake_INPUT_pre, @fake_INPUT, $_;
870					# $_ = "";
871					# $processing_arg_with_types = 1;
872					# INPUT_handler();
873					# }
874					# print $deferred;
875					#
876					# process_keyword("INIT\|ALIAS\|ATTRS\|PROTOTYPE\|INTERFACE_MACRO\|INTERFACE\|C_ARGS\|OVERLOAD");
877					#
878					# if (check_keyword("PPCODE")) {
879					# print_section();
880					# death ("PPCODE must be last thing") if @line;
881					# print "\tLEAVE;\n" if $ScopeThisXSUB;
882					# print "\tPUTBACK;\n\treturn;\n";
883					# }
884					# elsif (check_keyword("CODE")) {
885					# print_section();
886					# }
887					# elsif (defined($class) and $func_name eq "DESTROY") {
888					# print "\n\t";
889					# print "delete THIS;\n";
890					# }
891					# else {
892					# print "\n\t";
893					# if ($ret_type ne "void") {
894					# print "RETVAL = ";
895					# $wantRETVAL = 1;
896					# }
897					# if (defined($static)) {
898					# if ($func_name eq 'new') {
899					# $func_name = "$class";
900					# }
901					# else {
902					# print "${class}::";
903					# }
904					# }
905					# elsif (defined($class)) {
906					# if ($func_name eq 'new') {
907					# $func_name .= " $class";
908					# }
909					# else {
910					# print "THIS->";
911					# }
912					# }
913					# $func_name =~ s/^\Q$args{'s'}//
914					# if exists $args{'s'};
915					# $func_name = 'XSFUNCTION' if $interface;
916					# print "$func_name($func_args);\n";
917					# }
918					# }
919					#
920					# # do output variables
921					# $gotRETVAL = 0; # 1 if RETVAL seen in OUTPUT section;
922					# undef $RETVAL_code; # code to set RETVAL (from OUTPUT section);
923					# # $wantRETVAL set if 'RETVAL =' autogenerated
924					# ($wantRETVAL, $ret_type) = (0, 'void') if $RETVAL_no_return;
925					# undef %outargs;
926					# process_keyword("POSTCALL\|OUTPUT\|ALIAS\|ATTRS\|PROTOTYPE\|OVERLOAD");
927					#
928					# &generate_output($var_types{$_}, $args_match{$_}, $_, $DoSetMagic)
929					# for grep $in_out{$_} =~ /OUT$/, keys %in_out;
930					#
931					# # all OUTPUT done, so now push the return value on the stack
932					# if ($gotRETVAL && $RETVAL_code) {
933					# print "\t$RETVAL_code\n";
934					# }
935					# elsif ($gotRETVAL \|\| $wantRETVAL) {
936					# my $t = $WantOptimize && $targetable{$type_kind{$ret_type}};
937					# my $var = 'RETVAL';
938					# my $type = $ret_type;
939					#
940					# # 0: type, 1: with_size, 2: how, 3: how_size
941					# if ($t and not $t->[1] and $t->[0] eq 'p') {
942					# # PUSHp corresponds to setpvn. Treate setpv directly
943					# my $what = eval qq("$t->[2]");
944					# warn $@ if $@;
945					#
946					# print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n";
947					# $prepush_done = 1;
948					# }
949					# elsif ($t) {
950					# my $what = eval qq("$t->[2]");
951					# warn $@ if $@;
952					#
953					# my $size = $t->[3];
954					# $size = '' unless defined $size;
955					# $size = eval qq("$size");
956					# warn $@ if $@;
957					# print "\tXSprePUSH; PUSH$t->[0]($what$size);\n";
958					# $prepush_done = 1;
959					# }
960					# else {
961					# # RETVAL almost never needs SvSETMAGIC()
962					# &generate_output($ret_type, 0, 'RETVAL', 0);
963					# }
964					# }
965					#
966					# $xsreturn = 1 if $ret_type ne "void";
967					# my $num = $xsreturn;
968					# my $c = @outlist;
969					# print "\tXSprePUSH;" if $c and not $prepush_done;
970					# print "\tEXTEND(SP,$c);\n" if $c;
971					# $xsreturn += $c;
972					# generate_output($var_types{$_}, $num++, $_, 0, 1) for @outlist;
973					#
974					# # do cleanup
975					# process_keyword("CLEANUP\|ALIAS\|ATTRS\|PROTOTYPE\|OVERLOAD");
976					#
977					# print Q(<<"EOF") if $ScopeThisXSUB;
978					## ]]
979					#EOF
980					# print Q(<<"EOF") if $ScopeThisXSUB and not $PPCODE;
981					## LEAVE;
982					#EOF
983					#
984					# # print function trailer
985					# print Q(<<"EOF");
986					## ]]
987					#EOF
988					# print Q(<<"EOF") if $except;
989					## BEGHANDLERS
990					## CATCHALL
991					## sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
992					## ENDHANDLERS
993					#EOF
994					# if (check_keyword("CASE")) {
995					# blurt ("Error: No `CASE:' at top of function")
996					# unless $condnum;
997					# $_ = "CASE: $_"; # Restore CASE: label
998					# next;
999					# }
1000					# last if $_ eq "$END:";
1001					# death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function");
1002	14 14				@{ $self->{line} } = (); # just to make the tests pass
1003					}
1004
1005					# TODO: continue moving code into method below this line
1006					}
1007	2				return 1;
1008					}
1009
1010					sub check_keyword {
1011	52			52	my ($self, $thisline, $pattern) = @_;
1012	52 14		67		while ( $thisline !~ /\S/ && @{$self->{line}} ) {
1013	14 14				$thisline = shift( @{$self->{line}} );
1014					}
1015	52				$thisline =~ s/^(\s)($pattern)\s:\s(?:#.)?/$1/s;
1016	52		100		my $kwd = $2 \|\| 0;
1017	52				return ( $kwd, $thisline );
1018					}
1019
1020					sub PROTOTYPES_handler () {
1021	2			2	my ($self, $thisline) = @_;
1022					# the rest of the current line should contain either ENABLE or
1023					# DISABLE
1024					# $WantPrototypes replaced by $self->{prototypes}
1025
1026	2				TrimWhitespace($thisline);
1027
1028	2	50			if ($thisline =~ /^(ENABLE\|DISABLE)/) {
1029	2				my $status = $1;
1030	2	100			$self->{prototypes} = ($status eq 'ENABLE') ? 1 : 0;
1031	2				$self->{ProtoUsed} = 1;
1032	2				return $thisline;
1033					}
1034					else {
1035	0				croak "Error: PROTOTYPES: ENABLE/DISABLE: $!";
1036					}
1037					}
1038
1039					sub VERSIONCHECK_handler () {
1040	1			1	my ($self, $thisline) = @_;
1041					# the rest of the current line should contain either ENABLE or
1042					# DISABLE
1043					# $WantVersionChk replaced by $self->{versioncheck}
1044
1045	1				TrimWhitespace($thisline);
1046
1047	1	50			if ($thisline =~ /^(ENABLE\|DISABLE)/) {
1048	1				my $status = $1;
1049	1	50			$self->{versioncheck} = ($status eq 'ENABLE') ? 1 : 0;
1050	1				return $thisline;
1051					}
1052					else {
1053	0				croak "Error: VERSIONCHECK: ENABLE/DISABLE: $!";
1054					}
1055					}
1056
1057					sub REQUIRE_handler () {
1058	1			1	my ($self, $Ver) = @_;
1059					# the rest of the current line should contain a version number
1060
1061	1				TrimWhitespace($Ver);
1062
1063	1	50			croak "Error: REQUIRE expects a version number: $!"
1064					unless $Ver;
1065
1066					# check that the version number is of the form n.n
1067	1	50			croak "Error: REQUIRE: expected a number, got '$Ver': $!"
1068					# unless $Ver =~ /^\d+(\.\d*)?/;
1069					unless $Ver =~ /^\d+(\.\d(_\d)?)?/;
1070	1				$Ver =~ s/_//g;
1071	1				my $version = $VERSION;
1072	1				$version =~ s/_//g;
1073
1074	1	50			croak "Error: xsubpp $Ver (or better) required--this is only $version.: $!"
1075					unless $version >= $Ver;
1076					}
1077
1078					sub FALLBACK_handler() {
1079	1			1	my ($self, $thisline) = @_;
1080					# the rest of the current line should contain either TRUE,
1081					# FALSE or UNDEF
1082
1083	1				TrimWhitespace($thisline);
1084	1				my %map = (
1085					TRUE => "&PL_sv_yes", 1 => "&PL_sv_yes",
1086					FALSE => "&PL_sv_no", 0 => "&PL_sv_no",
1087					UNDEF => "&PL_sv_undef",
1088					);
1089
1090					# check for valid FALLBACK value
1091	1	50			croak "Error: FALLBACK: TRUE/FALSE/UNDEF: $!"
1092					unless exists $map{uc $thisline};
1093
1094	1				$self->{Fallback} = $map{uc $thisline};
1095	1				return $thisline;
1096					}
1097
1098					sub INCLUDE_handler () {
1099	1			1	my ($self, $thisline) = @_;
1100					# the rest of the current line should contain a valid filename
1101
1102	1				TrimWhitespace($thisline);
1103	1	50			croak "INCLUDE: filename missing: $!" unless $thisline;
1104
1105	1	50			croak "INCLUDE: output pipe is illegal: $!" if $thisline =~ /^\s*\\|/;
1106
1107					# simple minded recursion detector
1108	1	50			croak "INCLUDE loop detected: $!" if $self->{IncludedFiles}{$thisline};
1109
1110	1	50			++$self->{IncludedFiles}{$thisline} unless $thisline =~ /\\|\s*$/;
1111
1112					# Save the current file context.
1113	1 1				push @{ $self->{XSStack} }, {
1114					type => 'file',
1115					LastLine => $self->{lastline},
1116					LastLineNo => $self->{lastline_no},
1117					Line => $self->{line},
1118					LineNo => $self->{line_no},
1119					Filename => $self->{base},
1120					Filepathname => $self->{filepathname},
1121					Handle => $IN,
1122					};
1123
1124	1				$IN = Symbol::gensym();
1125
1126					# open the new file
1127	1	50			open ($IN, "$thisline") or croak "Cannot open '$thisline': $!";
1128
1129	1				$self->{out} .= Q(<<"EOF");
1130					#
1131					#/* INCLUDE: Including '$thisline' from '$self->{base}' */
1132					#
1133					EOF
1134
1135	1				$self->{filepathname} = $self->{base} = $thisline;
1136
1137					# Prime the pump by reading the first
1138					# non-blank line
1139
1140					# skip leading blank lines
1141	1				while ($thisline = <$IN>) {
1142	2	100			last unless $thisline =~ /^\s*$/;
1143					}
1144
1145	1				$self->{lastline} = $thisline;
1146	1				$self->{lastline_no} = $.;
1147	1				return $thisline;
1148					}
1149
1150					sub CASE_handler {
1151	1			1	my ($self, $thisline) = @_;
1152	1	50	33		if ($self->{condnum} && $self->{cond} eq '') {
1153	0				$self->warnline("Error: 'CASE:' after unconditional 'CASE:'");
1154	0				$self->{errors}++;
1155					}
1156	1				$self->{cond} = $thisline;
1157	1				TrimWhitespace($self->{cond});
1158	1	50 50			$self->{out} .= q{ } .
1159					($self->{condnum}++ ? " else" : "") .
1160					($self->{cond} ? " if ($self->{cond})\n" : "\n");
1161	1				$thisline = '';
1162	1				return $thisline;
1163					}
1164
1165					sub INPUT_handler {
1166	0			0	my ($self, $thisline) = @_;
1167	0 0				for (; $thisline !~ /^$self->{BLOCK_re}/o; $thisline = shift(@{ $self->{line} })) {
1168	0	0			last if $thisline =~ /^\s*NOT_IMPLEMENTED_YET/;
1169	0	0			next unless $thisline =~ /\S/; # skip blank lines
1170
1171	0				TrimWhitespace($thisline);
1172	0				my $line = $thisline;
1173
1174					# remove trailing semicolon if no initialisation
1175	0	0			$thisline =~ s/\s;$//g unless $thisline =~ /[=;+].\S/;
1176
1177					# Process the length(foo) declarations
1178	0	0			if ($thisline =~ s/^([^=])\blength$\s(\w+)\s$\s$/$1 XSauto_length_of_$2=NO_INIT/x) {
1179	0				my ($foo, $bar) = ($1, $2);
1180	0				$self->{out} .= "\tSTRLEN\tSTRLEN_length_of_$bar;\n";
1181	0				$self->{lengthof}{$bar} = $self->{name};
1182	0				$self->{deferred} .=
1183					"\n\tXSauto_length_of_$bar = STRLEN_length_of_$bar;\n";
1184					}
1185
1186					# check for optional initialisation code
1187	0				my $var_init = '';
1188	0	0			$var_init = $1 if $thisline =~ s/\s([=;+].)$//s;
1189	0				$var_init =~ s/"/\\"/g;
1190
1191	0				$thisline =~ s/\s+/ /g;
1192	0	0			unless ( $thisline =~ /^(.?[^&\s])\s(\&?)\s*\b(\w+)$/s ) {
1193	0				$self->warnline("Error: invalid argument declaration '$line': $!");
1194	0				$self->{errors}++;
1195	0				next;
1196					};
1197	0				my ($var_type, $var_addr, $var_name) = ($1, $2, $3);
1198
1199
1200					# Check for duplicate definitions
1201					# blurt ("Error: duplicate definition of argument '$var_name' ignored"),
1202					# next if $arg_list{$var_name}++
1203					# or defined $argtype_seen{$var_name}
1204					# and not $processing_arg_with_types;
1205	0	0	0		if ( $self->{arg_list}{$var_name}++
1206					or defined $self->{argtype_seen}{$var_name}
1207					and not $self->{processing_arg_with_types}
1208					) {
1209	0				$self->warnline("Error: duplicate definition of argument '$var_name' ignored");
1210	0				$self->{errors}++;
1211	0				next;
1212					}
1213
1214	0				$self->{thisdone} \|= $var_name eq "THIS";
1215	0				$self->{retvaldone} \|= $var_name eq "RETVAL";
1216	0				$self->{var_types}->{$var_name} = $var_type;
1217					# XXXX This check is a safeguard against the unfinished conversion of
1218					# generate_init(). When generate_init() is fixed,
1219					# one can use 2-args map_type() unconditionally.
1220	0	0			if ($var_type =~ / $ \s* \* \s* $ /x) {
1221					# Function pointers are not yet supported with &output_init!
1222	0				$self->{out} .= "\t" . $self->map_type($var_type, $var_name);
1223	0				$self->{name_printed} = 1;
1224					}
1225					else {
1226	0				$self->{out} .= "\t" . $self->map_type($var_type);
1227	0				$self->{name_printed} = 0;
1228					}
1229	0				$self->{var_num} = $self->{args_match}{$var_name};
1230
1231	0	0			$self->{proto_arg}[$self->{var_num}] = ProtoString($var_type)
1232					if $self->{var_num};
1233	0	0			$self->{func_args} =~ s/\b($var_name)\b/&$1/ if $var_addr;
1234	0	0 0 0	0		if ($var_init =~ /^[=;]\sNO_INIT\s;?\s*$/
1235					or $self->{in_out}{$var_name}
1236					and $self->{in_out}{$var_name} =~ /^OUT/
1237					and $var_init !~ /\S/
1238					) {
1239	0	0			if ($self->{name_printed}) {
1240	0				$self->{out} .= ";\n";
1241					}
1242					else {
1243	0				$self->{out} .= "\t$var_name;\n";
1244					}
1245					}
1246					elsif ($var_init =~ /\S/) {
1247					# &output_init($var_type, $self->{var_num}, $var_name, $var_init, $name_printed);
1248	0				$self->output_init( $var_type, $var_name );
1249					}
1250					elsif ($self->{var_num}) {
1251					# # generate initialization code
1252					# &generate_init($var_type, $self->{var_num}, $var_name, $name_printed);
1253	0				$self->generate_init($var_type, $var_name);
1254					}
1255					else {
1256	0				$self->{out} .= ";\n";
1257					}
1258					}
1259					}
1260
1261					sub map_type {
1262	0			0	my ($self, $type, $varname) = @_;
1263
1264					# C++ has :: in types too so skip this
1265	0	0			$type =~ tr/:/_/ unless $self->{hiertype};
1266	0				$type =~ s/^array$([^,]),(.)$./$1 /s;
1267	0	0			if ($varname) {
1268	0	0	0		if ($varname && $type =~ / $ \s* \* (?= \s* $ ) /xg) {
1269	0				(substr $type, pos $type, 0) = " $varname ";
1270					}
1271					else {
1272	0				$type .= "\t$varname";
1273					}
1274					}
1275	0				return $type;
1276					}
1277
1278					sub ProtoString {
1279	0			0	my ($self, $type) = @_;
1280	0	0			return $self->{proto_letter}{$type} or "\$";
1281					}
1282
1283					sub check_cpp {
1284	15			15	my ($self) = @_;
1285	15 15				my @cpp = grep(/^\#\s*(?:if\|e\w+)/, @{ $self->{line} });
1286	15	50			if (@cpp) {
1287	0				my ($cpp, $cpplevel);
1288	0				for $cpp (@cpp) {
1289	0	0 0 0			if ($cpp =~ /^\#\s*if/) {
1290	0				$cpplevel++;
1291					}
1292					elsif (!$cpplevel) {
1293	0				carp "Warning: #else/elif/endif without #if in this function: $!";
1294	0	0			print STDERR " (precede it with a blank line if the matching #if is outside the function)\n"
1295					if $self->{XSStack}->[-1]{type} eq 'if';
1296	0				return;
1297					}
1298					elsif ($cpp =~ /^\#\s*endif/) {
1299	0				$cpplevel--;
1300					}
1301					}
1302	0	0			carp "Warning: #if without #endif in this function: $!" if $cpplevel;
1303					}
1304					}
1305
1306
1307					############ END PUBLIC MAIN METHODS ###########
1308					#
1309					######## BEGIN PUBLIC AUXILIARY METHODS ########
1310
1311					sub get {
1312	116	100		116	croak "Need one argument to method get(): $!"
1313					unless @_ == 2;
1314	115				my ($self, $arg) = @_;
1315	115	100			return unless exists $self->{$arg};
1316	105				return $self->{$arg};
1317					}
1318
1319					sub set {
1320	2	100		2	croak "Need two arguments to method set(): $!"
1321					unless @_ == 3;
1322	1				my ($self, $attr, $val) = @_;
1323	1				$self->{$attr} = $val;
1324					}
1325
1326					########## END PUBLIC AUXILIARY METHODS ##########
1327					#
1328					######## BEGIN INTERNAL METHODS ########
1329
1330					sub ValidProtoString ($) {
1331	2039			2039	my ( $self, $string ) = @_;
1332	2039	50			return $string if $string =~ m/^$self->{proto_re}+$/o;
1333	0				return 0;
1334					}
1335
1336					# fetch_para(): Read next xsub into @line from ($lastline, <$FH>).
1337					# Subs/methods needed within: death(); PopFile();
1338					# EUOOPXS object attributes needed: lastline; XSStack; Package; Prefix;
1339					# Module_cname; Packid; IncludedFiles; base (formerly $filename);
1340					#
1341
1342 - 1374					=head2 C<fetch_para()> B<Purpose:> Conduct a first-pass at parsing the portion of the F<.xs> file below the C<MODULE> line and return one paragraph with each execution. B<Arguments:> None. All data needed is present in the ExtUtils::OOParseXS object or in C<$ExtUtils::OOParseXS::IN>, the read filehandle. B<Return Values:> A single array reference, but with two different cases: =over 4 =item 1 If the current line is undefined and if the C<type> attribute for the top item of the XSStack is not C<file>, then C<0> is returned as the value of the first element (index C<0>) of the array reference. This will terminate the C<while> loop in which C<fetch_para()> is called. NO IT WON'T. =item 2 More typically, parsing of a paragraph will return a list of two array references. The first array contains (a slightly normalized version of) the lines of the paragraph. The second contains the line numbers at which those lines were located in the F<.xs> file. =back B<Comment:> If the current line is defined and if the C<type> attribute for the top item of the XSStack I<is> C<file>, then that item is C<pop>ped off that stack and it is parsed by this subroutine. =cut
1375
1376					sub fetch_para {
1377	45			45	my ($self) = @_;
1378					# # parse paragraph
1379					# death ("Error: Unterminated `#if/#ifdef/#ifndef'")
1380					# if !defined $lastline && $XSStack[-1]{type} eq 'if';
1381	45	50	67		if (
1382					( ! defined $self->{lastline} ) &&
1383					( $self->{XSStack}->[-1]{type} eq 'if' )
1384					) {
1385	0				croak "Error: Unterminated `#if/#ifdef/#ifndef' in $self->{base}: $!";
1386					}
1387					# If we're assigning empty lists to these two arrays here, then presumably
1388					# we can turn them into sub-scoped lexicals.
1389					# @line = ();
1390					# @line_no = ();
1391	45				my @line = ();
1392	45				my @line_no = ();
1393					##### START of what used to be Popfile() #####
1394					# Below is the only instance of Popfile(). For devel purposes, it may be
1395					# better to paste it in here.
1396					# It may also be better to make an explicit if-else branch here.
1397					# return PopFile() if !defined $lastline;
1398	45	100			if ( ! defined $self->{lastline} ) {
1399	4	100			if ( $self->{XSStack}->[-1]{type} eq 'file' ) {
1400	1 1				my $data = pop @{ $self->{XSStack} };
1401	1				my $ThisFile = $self->{base};
1402	1				my $isPipe = ($self->{base} =~ /\\|\s*$/);
1403
1404	1	50			--$self->{IncludedFiles}->{$self->{base}}
1405					unless $isPipe;
1406
1407	1				close $IN;
1408
1409	1				$IN = $data->{Handle};
1410
1411					# $self->{base} is the leafname, which for some reason isused for
1412					# diagnostic messages, whereas $self->{filepathname} is the full
1413					# pathname, and is used for #line directives.
1414
1415	1				$self->{base} = $data->{Filename};
1416	1				$self->{filepathname} = $data->{Filepathname};
1417	1				$self->{lastline} = $data->{LastLine};
1418	1				$self->{lastline_no} = $data->{LastLineNo};
1419	1 1				@line = @{ $data->{Line} };
1420	1 1				@line_no = @{ $data->{LineNo} };
1421
1422	1	50	33		if ($isPipe and $? ) {
1423	0				--$self->{lastline_no};
1424					# print STDERR "Error reading from pipe '$ThisFile': $! in $self->{base}, line $self->{lastline_no}\n";
1425					# exit 1;
1426	0				croak "Error reading from pipe '$ThisFile': $! in $self->{base}, line $self->{lastline_no}\n";
1427					}
1428
1429	1				$self->{out} .= Q(<<"EOF");
1430					#
1431					#/* INCLUDE: Returning to '$self->{base}' from '$ThisFile' */
1432					#
1433					EOF
1434					}
1435	4				return [ 0, undef ];
1436					} ##### END of what used to be Popfile() #####
1437					else {
1438					# Haven't I seen this regex before? If so, I can make it into an
1439					# attribute. Umm, not quite, it differs with respect to what is captured.
1440	41	100			if ($self->{lastline} =~
1441					/^MODULE\s=\s([\w:]+)(?:\s+PACKAGE\s=\s([\w:]+))?(?:\s+PREFIX\s=\s(\S+))?\s*$/) {
1442	4				my $Module = $1;
1443	4	100			$self->{Package} = defined($2) ? $2 : ''; # keep -w happy
1444	4	100			$self->{Prefix} = defined($3) ? $3 : ''; # keep -w happy
1445	4				$self->{Prefix} = quotemeta $self->{Prefix};
1446	4				($self->{Module_cname} = $Module) =~ s/\W/_/g;
1447	4				($self->{Packid} = $self->{Package}) =~ tr/:/_/;
1448	4				$self->{Packprefix} = $self->{Package};
1449	4	100			$self->{Packprefix} .= "::" if $self->{Packprefix} ne "";
1450	4				$self->{lastline} = "";
1451					}
1452
1453	41				for (;;) {
1454					# Skip embedded PODs
1455	282				while ($self->{lastline} =~ /^=/) {
1456	1				while ($self->{lastline} = <$IN>) {
1457	4	100			last if ($self->{lastline} =~ /^=cut\s*$/);
1458					}
1459					# death ("Error: Unterminated pod") unless $self->{lastline};
1460	1	50			croak "Error: Unterminated pod: $!" unless $self->{lastline};
1461	1				$self->{lastline} = <$IN>;
1462	1				chomp $self->{lastline};
1463	1				$self->{lastline} =~ s/^\s+$//;
1464					}
1465					# If 'lastline is either not a comment or is a CPP directive ...
1466					# CPP directives:
1467					# ANSI: if ifdef ifndef elif else endif define undef
1468					# line error pragma
1469					# gcc: warning include_next
1470					# obj-c: import
1471					# others: ident (gcc notes that some cpps have this one)
1472	282	100	100		if ($self->{lastline} !~ /^\s*#/ \|\|
1473					$self->{lastline} =~ /^#[ \t](?:(?:if\|ifn?def\|elif\|else\|endif\|define\|undef\|pragma\|error\|warning\|line\s+\d+\|ident)\b\|(?:include(?:_next)?\|import)\s["<].*[>"])/) {
1474	281	100	100		last if $self->{lastline} =~ /^\S/ && @line && $line[-1] eq "";
1475	244				push(@line, $self->{lastline});
1476	244				push(@line_no, $self->{lastline_no});
1477					}
1478
1479					# Read next line and continuation lines
1480	245	100			last unless defined($self->{lastline} = <$IN>);
1481	241				$self->{lastline_no} = $.;
1482	241				my $tmp_line;
1483					# $self->{lastline} .= $tmp_line
1484					# while ($self->{lastline} =~ /\\$/ && defined($tmp_line = <$IN>));
1485	241		33		while ($self->{lastline} =~ /\\$/ && defined($tmp_line = <$IN>)) {
1486	0				$self->{lastline} .= $tmp_line;
1487					}
1488
1489	241				chomp $self->{lastline};
1490	241				$self->{lastline} =~ s/^\s+$//;
1491					}
1492					# pop(@line), pop(@line_no) while @line && $line[-1] eq "";
1493					# 1;
1494					# Returns reference to a 2-item list of array refs:
1495	41				return doublepop( [ @line ], [ @line_no ] );
1496					}
1497					}
1498
1499					sub warnline {
1500	0			0	my ($self, @message) = @_;
1501	0				my $line_no =
1502	0 0				$self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} }- 1];
1503	0				carp "@message in $self->{base}, line $line_no: $!";
1504					}
1505
1506					########## END INTERNAL METHODS ##########
1507					#
1508					####### BEGIN INTERNAL SUBROUTINES #######
1509
1510 - 1524					=head2 B<Purpose:> Prepare a list of the standard locations in which typemaps for F<.xs> files may be located. A typemap has higher priority the B<later> it appears in this list. B<Arguments:> May take a single user-supplied scalar to hold the name of a typemap which is to have priority over all others. This is useful during testing of this subroutine. B<Return Value:> Array of relative paths to typemaps. B<Comment:> =cut
1525
1526					sub standard_typemap_locations {
1527					# Add all the default typemap locations to the search path
1528	21			21	my @tm = qw(typemap);
1529					# During testing, make sure a user-supplied typemap takes priority
1530	21	50			push @tm, $_[0] if defined $_[0];
1531
1532	21				my $updir = File::Spec->updir;
1533	21				foreach my $dir (File::Spec->catdir(($updir) x 1), File::Spec->catdir(($updir) x 2),
1534					File::Spec->catdir(($updir) x 3), File::Spec->catdir(($updir) x 4)) {
1535	84				unshift @tm, File::Spec->catfile($dir, 'typemap');
1536	84				unshift @tm, File::Spec->catfile($dir, lib => ExtUtils => 'typemap');
1537					}
1538	21				foreach my $dir (@INC) {
1539	210				my $file = File::Spec->catfile($dir, ExtUtils => 'typemap');
1540	210	100			unshift @tm, $file if -e $file;
1541					}
1542	21				return @tm;
1543					}
1544
1545 - 1553					=head2 C<TrimWhitespace()> B<Purpose:> In-place trimming of leading and trailing whitespace. B<Argument:> One scalar: the string needing trimming: B<Return Value:> None; change is done in place. =cut
1554
1555					sub TrimWhitespace {
1556	4181			4181	$_[0] =~ s/^\s+\|\s+$//go;
1557					}
1558
1559 - 1584					=head2 C<TidyType> B<Purpose:> Tidying strings in several steps: =over 4 =item * Consecutive asterisks (C<>), possibly surrounded by whitespace, are rewritten to be surrounded by a single whitespace on either side. =item Multiple whitespaces are reduced to a single whitespace. =item * c<TrimWhitespace()> is then applied. =back B<Argument:> One scalar: the string needing trimming: B<Return Value:> None; change is done in place. =cut
1585
1586					sub TidyType {
1587	2054			2054	local ($_) = @_;
1588
1589					# rationalise any '*' by joining them into bunches and removing whitespace
1590	2054				s#\s(\+)\s*#$1#g;
1591	2054				s#(\*+)# $1 #g;
1592
1593					# change multiple whitespace into a single space
1594	2054				s/\s+/ /g;
1595
1596					# trim leading & trailing whitespace
1597	2054				TrimWhitespace($_);
1598
1599	2054				return $_;
1600					}
1601
1602					sub C_string ($) {
1603	2039			2039	my ( $string ) = @_;
1604	2039				$string =~ s[\\][\\\\]g;
1605	2039				return $string;
1606					}
1607
1608					sub doublepop {
1609	41			41	my ($line_ref, $line_no_ref) = @_;
1610	41 89 48 48		100		pop(@{$line_ref}), pop(@{$line_no_ref}) while @{$line_ref} && $line_ref->[-1] eq "";
1611	41				return [ $line_ref, $line_no_ref ];
1612					}
1613
1614					sub Q {
1615	48			48	my($text) = @_;
1616	48				$text =~ s/^#//gm;
1617	48				$text =~ s/\[\[/{/g;
1618	48				$text =~ s/\]\]/}/g;
1619	48				return $text;
1620					}
1621
1622					sub generate_init {
1623					# my ($type, $num, $var) = @_;
1624	0			0	my ($self, $type, $num) = @_;
1625	0				my ($arg) = "ST(" . ($num - 1) . ")";
1626	0				my ($argoff) = $num - 1;
1627	0				my ($ntype);
1628	0				my ($tk);
1629
1630	0				$type = TidyType($type);
1631					# blurt("Error: '$type' not in typemap"), return
1632					# unless defined($type_kind{$type});
1633	0	0			unless ( defined($self->{type_kind}{$type}) ){
1634	0				$self->warnline("Error: '$type' not in typemap: $!");
1635	0				$self->{errors}++;
1636	0				return;
1637					}
1638
1639	0				($ntype = $type) =~ s/\s\/Ptr/g;
1640	0				($self->{subtype} = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
1641	0				$tk = $self->{type_kind}{$type};
1642	0	0			$tk =~ s/OBJ$/REF/ if $self->{func_name} =~ /DESTROY$/;
1643	0	0	0		if ($tk eq 'T_PV' and exists $self->{lengthof}{$self->{var}}) {
1644	0	0			$self->{out} .= "\t$self->{var}" unless $self->{name_printed};
1645	0				$self->{out} .= " = ($type)SvPV($arg, STRLEN_length_of_$self->{var});\n";
1646	0	0			die "default value not supported with length(NAME) supplied"
1647					if defined $self->{defaults}{$self->{var}};
1648	0				return;
1649					}
1650	0	0			$type =~ tr/:/_/ unless $self->{hiertype};
1651					# blurt("Error: No INPUT definition for type '$type', typekind '$type_kind{$type}' found"),
1652					# return unless defined $input_expr{$tk};
1653	0	0			unless ( defined( $self->{input_expr}{$tk} ) ) {
1654	0				$self->warnline("Error: No INPUT definition for type '$type', typekind '$self->{type_kind}{$type}' found");
1655	0				$self->errors++;
1656	0				return;
1657					}
1658	0				$self->{expr} = $self->{input_expr}{$tk};
1659	0	0			if ($self->{expr} =~ /DO_ARRAY_ELEM/) {
1660					# blurt("Error: '$subtype' not in typemap"),
1661					# return unless defined($type_kind{$subtype});
1662	0	0			unless ( defined( $self->{type_kind}{$self->{subtype}} ) ) {
1663	0				$self->warnline("Error: '$self->{subtype}' not in typemap: $!");
1664	0				$self->{errors}++;
1665	0				return;
1666					}
1667					# blurt("Error: No INPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"),
1668					# return unless defined $input_expr{$type_kind{$subtype}};
1669	0	0			unless ( defined( $self->{input_expr}{$self->{type_kind}}{$self->{subtype}} ) ) {
1670	0				$self->warnline("Error: No INPUT definition for type '$self->{subtype}', typekind '$self->{type_kind}{$self->{subtype}}' found: $!");
1671	0				$self->{errors}++;
1672	0				return;
1673					}
1674	0				$self->{subexpr} = $self->{input_expr}{$self->{type_kind}}{$self->{subtype}};
1675	0				$self->{subexpr} =~ s/\$type/\$self->{subtype}/g;
1676	0				$self->{subexpr} =~ s/ntype/subtype/g;
1677	0				$self->{subexpr} =~ s/\$arg/ST(ix_$self->{var})/g;
1678	0				$self->{subexpr} =~ s/\n\t/\n\t\t/g;
1679	0				$self->{subexpr} =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$self->{var} + 1/g;
1680	0				$self->{subexpr} =~ s/\$var/$self->{var}[ix_$self->{var} - $argoff]/;
1681	0				$self->{expr} =~ s/DO_ARRAY_ELEM/$self->{subexpr}/;
1682					}
1683	0	0			if ($self->{expr} =~ m#/\.scope.\/#i) { # "scope" in C comments
1684	0				$self->{ScopeThisXSUB} = 1;
1685					}
1686	0	0 0	0		if (defined($self->{defaults}{$self->{var}})) {
1687	0				$self->{expr} =~ s/(\t+)/$1 /g;
1688	0				$self->{expr} =~ s/ /\t/g;
1689	0	0			if ($self->{name_printed}) {
1690	0				$self->{out} .= ";\n";
1691					}
1692					else {
1693	0				eval qq/$self->{out} .= "\\t$self->{var};\\n"/;
1694	0	0			warn $@ if $@;
1695					}
1696	0	0			if ($self->{defaults}{$self->{var}} eq 'NO_INIT') {
1697	0				$self->{deferred} .= eval qq/"\\n\\tif (items >= $num) {\\n$self->{expr};\\n\\t}\\n"/;
1698					}
1699					else {
1700	0				$self->{deferred} .= eval qq/"\\n\\tif (items < $num)\\n\\t $self->{var} = $self->{defaults}{$self->{var}};\\n\\telse {\\n$self->{expr};\\n\\t}\\n"/;
1701					}
1702	0	0			warn $@ if $@;
1703					}
1704					elsif ($self->{ScopeThisXSUB} or $self->{expr} !~ /^\s*\$self->{var} =/) {
1705	0	0			if ($self->{name_printed}) {
1706	0				$self->{out} .= ";\n";
1707					}
1708					else {
1709	0				eval qq/$self->{out} .= "\\t$self->{var};\\n"/;
1710	0	0			warn $@ if $@;
1711					}
1712	0				$self->{deferred} .= eval qq/"\\n$self->{expr};\\n"/;
1713	0	0			warn $@ if $@;
1714					}
1715					else {
1716	0	0			if ($self->{name_printed}) {
1717	0				croak "panic: do not know how to handle this branch for function pointers: $!";
1718					}
1719	0				eval qq/$self->{out} .= "$self->{expr};\\n"/;
1720	0	0			warn $@ if $@;
1721					}
1722					}
1723
1724					sub output_init {
1725					## local($type, $num, $var, $init, $name_printed) = @_;
1726					## local($arg) = "ST(" . ($num - 1) . ")";
1727					# $self->output_init( $var_type, $var_name );
1728	0			0	my ($self, $type, $var, $init) = @_;
1729	0				my ($arg) = "ST(" . ($self->{var_num} - 1) . ")";
1730
1731	0	0			if ( $init =~ /^=/ ) {
1732	0	0			if ($self->{name_printed}) {
1733	0				eval qq/$self->{out} .= " $init\\n"/;
1734					}
1735					else {
1736	0				eval qq/$self->{out} .= "\\t$var $init\\n"/;
1737					}
1738	0	0			warn $@ if $@;
1739					}
1740					else {
1741	0	0 0	0		if ( $init =~ s/^\+// && $self->{var_num} ) {
1742					# &generate_init($type, $self->{var_num}, $var, $self->{name_printed});
1743	0				$self->generate_init($type, $var);
1744					}
1745					elsif ($self->{name_printed}) {
1746	0				$self->{out} .= ";\n";
1747	0				$init =~ s/^;//;
1748					}
1749					else {
1750	0				eval qq/$self->{out} .= "\\t$var;\\n"/;
1751	0	0			warn $@ if $@;
1752	0				$init =~ s/^;//;
1753					}
1754	0				$self->{deferred} .= eval qq/"\\n\\t$init\\n"/;
1755	0	0			warn $@ if $@;
1756					}
1757					}
1758
1759					1;
1760
1761					###########################################################
1762
1763					package ExtUtils::OOParseXS::CountLines;
1764	12 12 12			12	use strict;
1765					our $SECTION_END_MARKER;
1766
1767					sub TIEHANDLE {
1768	3			3	my ($class, $cfile, $fh) = @_;
1769	3				$cfile =~ s/\\/\\\\/g;
1770	3				$SECTION_END_MARKER = qq{#line --- "$cfile"};
1771
1772	3				return bless {buffer => '',
1773					fh => $fh,
1774					line_no => 1,
1775					}, $class;
1776					}
1777
1778					sub PRINT {
1779	0			0	my ($self) = @_;
1780	0				for (@_) {
1781	0				$self->{buffer} .= $_;
1782	0				while ($self->{buffer} =~ s/^([^\n]*\n)//) {
1783	0				my $line = $1;
1784	0				++ $self->{line_no};
1785	0				$line =~ s\|^\#line\s+---(?=\s)\|#line $self->{line_no}\|;
1786	0 0				print {$self->{fh}} $line;
1787					}
1788					}
1789					}
1790
1791					sub PRINTF {
1792	0			0	my ($self) = @_;
1793	0				my $fmt = shift;
1794	0				$self->PRINT(sprintf($fmt, @_));
1795					}
1796
1797					sub DESTROY {
1798					# Not necessary if we're careful to end with a "\n"
1799	2			2	my ($self) = @_;
1800	2 2				print {$self->{fh}} $self->{buffer};
1801					}
1802
1803	0			0	sub UNTIE {
1804					# This sub does nothing, but is neccessary for references to be released.
1805					}
1806
1807					sub end_marker {
1808	0			0	return $SECTION_END_MARKER;
1809					}
1810
1811					1;
1812
1813					#XXXXX
1814					#
1815					# print Q(<<"EOF") if $except;
1816					## if (errbuf[0])
1817					## Perl_croak(aTHX_ errbuf);
1818					#EOF
1819					#
1820					# if ($xsreturn) {
1821					# print Q(<<"EOF") unless $PPCODE;
1822					## XSRETURN($xsreturn);
1823					#EOF
1824					# }
1825					# else {
1826					# print Q(<<"EOF") unless $PPCODE;
1827					## XSRETURN_EMPTY;
1828					#EOF
1829					# }
1830					#
1831					# print Q(<<"EOF");
1832					##]]
1833					##
1834					#EOF
1835					#
1836					# my $newXS = "newXS";
1837					# my $proto = "";
1838					#
1839					# # Build the prototype string for the xsub
1840					# if ($ProtoThisXSUB) {
1841					# $newXS = "newXSproto";
1842					#
1843					# if ($ProtoThisXSUB eq 2) {
1844					# # User has specified empty prototype
1845					# }
1846					# elsif ($ProtoThisXSUB eq 1) {
1847					# my $s = ';';
1848					# if ($min_args < $num_args) {
1849					# $s = '';
1850					# $proto_arg[$min_args] .= ";";
1851					# }
1852					# push @proto_arg, "$s\@" if $ellipsis;
1853					#
1854					# $proto = join ("", grep defined, @proto_arg);
1855					# }
1856					# else {
1857					# # User has specified a prototype
1858					# $proto = $ProtoThisXSUB;
1859					# }
1860					# $proto = qq{, "$proto"};
1861					# }
1862					#
1863					# if (%XsubAliases) {
1864					# $XsubAliases{$pname} = 0
1865					# unless defined $XsubAliases{$pname};
1866					# while ( my ($name, $value) = each %XsubAliases) {
1867					# push(@InitFileCode, Q(<<"EOF"));
1868					## cv = newXS(\"$name\", XS_$Full_func_name, file);
1869					## XSANY.any_i32 = $value;
1870					#EOF
1871					# push(@InitFileCode, Q(<<"EOF")) if $proto;
1872					## sv_setpv((SV*)cv$proto);
1873					#EOF
1874					# }
1875					# }
1876					# elsif (@Attributes) {
1877					# push(@InitFileCode, Q(<<"EOF"));
1878					## cv = newXS(\"$pname\", XS_$Full_func_name, file);
1879					## apply_attrs_string("$Package", cv, "@Attributes", 0);
1880					#EOF
1881					# }
1882					# elsif ($interface) {
1883					# while ( my ($name, $value) = each %Interfaces) {
1884					# $name = "$Package\::$name" unless $name =~ /::/;
1885					# push(@InitFileCode, Q(<<"EOF"));
1886					## cv = newXS(\"$name\", XS_$Full_func_name, file);
1887					## $interface_macro_set(cv,$value);
1888					#EOF
1889					# push(@InitFileCode, Q(<<"EOF")) if $proto;
1890					## sv_setpv((SV*)cv$proto);
1891					#EOF
1892					# }
1893					# }
1894					# else {
1895					# push(@InitFileCode,
1896					# " ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n");
1897					# }
1898					# } # END: PARAGRAPH
1899					# # make it findable with fetchmethod
1900					# # $proto in block below seems out of scope -- jk 20090731
1901					# if ($Overload) {
1902					# print Q(<<"EOF");
1903					##XS(XS_${Packid}_nil); /* prototype to pass -Wmissing-prototypes */
1904					##XS(XS_${Packid}_nil)
1905					##{
1906					## dXSARGS;
1907					## XSRETURN_EMPTY;
1908					##}
1909					##
1910					#EOF
1911					# unshift(@InitFileCode, <<"MAKE_FETCHMETHOD_WORK");
1912					# /* Making a sub named "${Package}::()" allows the package */
1913					# /* to be findable via fetchmethod(), and causes */
1914					# /* overload::Overloaded("${Package}") to return true. */
1915					# newXS("${Package}::()", XS_${Packid}_nil, file$proto);
1916					#MAKE_FETCHMETHOD_WORK
1917					# }
1918					#
1919					# # print initialization routine
1920					#
1921					# print Q(<<"EOF");
1922					###ifdef __cplusplus
1923					##extern "C"
1924					###endif
1925					#EOF
1926					#
1927					# print Q(<<"EOF");
1928					##XS(boot_$Module_cname); /* prototype to pass -Wmissing-prototypes */
1929					##XS(boot_$Module_cname)
1930					#EOF
1931					#
1932					# print Q(<<"EOF");
1933					##[[
1934					###ifdef dVAR
1935					## dVAR; dXSARGS;
1936					###else
1937					## dXSARGS;
1938					###endif
1939					#EOF
1940					#
1941					# #Under 5.8.x and lower, newXS is declared in proto.h as expecting a non-const
1942					# #file name argument. If the wrong qualifier is used, it causes breakage with
1943					# #C++ compilers and warnings with recent gcc.
1944					# my $file_decl = ($] < 5.009) ? "char file[]" : "const char* file";
1945					#
1946					# #-Wall: if there is no $Full_func_name there are no xsubs in this .xs
1947					# #so `file' is unused
1948					# print Q(<<"EOF") if $Full_func_name;
1949					## $file_decl = __FILE__;
1950					#EOF
1951					#
1952					# print Q("#\n");
1953					#
1954					# print Q(<<"EOF");
1955					## PERL_UNUSED_VAR(cv); /* -W */
1956					## PERL_UNUSED_VAR(items); /* -W */
1957					#EOF
1958					#
1959					# print Q(<<"EOF") if $WantVersionChk;
1960					## XS_VERSION_BOOTCHECK;
1961					##
1962					#EOF
1963					#
1964					# print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces;
1965					## {
1966					## CV * cv;
1967					##
1968					#EOF
1969					#
1970					# print Q(<<"EOF") if ($Overload);
1971					## /* register the overloading (type 'A') magic */
1972					## PL_amagic_generation++;
1973					## /* The magic for overload gets a GV* via gv_fetchmeth as */
1974					## /* mentioned above, and looks in the SV* slot of it for */
1975					## /* the "fallback" status. */
1976					## sv_setsv(
1977					## get_sv( "${Package}::()", TRUE ),
1978					## $Fallback
1979					## );
1980					#EOF
1981					#
1982					# print @InitFileCode;
1983					#
1984					# print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces;
1985					## }
1986					#EOF
1987					#
1988					# if (@BootCode) {
1989					# print "\n /* Initialisation Section */\n\n";
1990					# @line = @BootCode;
1991					# print_section();
1992					# print "\n /* End of Initialisation Section */\n\n";
1993					# }
1994					#
1995					# if ($] >= 5.009) {
1996					# print <<'EOF';
1997					# if (PL_unitcheckav)
1998					# call_list(PL_scopestack_ix, PL_unitcheckav);
1999					#EOF
2000					# }
2001					#
2002					# print Q(<<"EOF");
2003					## XSRETURN_YES;
2004					##]]
2005					##
2006					#EOF
2007					#
2008					# warn("Please specify prototyping behavior for $filename (see perlxs manual)\n")
2009					# unless $ProtoUsed;
2010					#
2011					# chdir($orig_cwd);
2012					# select($orig_fh);
2013					# untie PSEUDO_STDOUT if tied PSEUDO_STDOUT;
2014					# close $FH;
2015					#
2016					# return 1;
2017					#}
2018					#
2019					#sub errors { $errors }
2020					#
2021					## Input: ($_, @line) == unparsed input.
2022					## Output: ($_, @line) == (rest of line, following lines).
2023					## Return: the matched keyword if found, otherwise 0
2024					#sub check_keyword {
2025					# $_ = shift(@line) while !/\S/ && @line;
2026					# s/^(\s)($_[0])\s:\s(?:#.)?/$1/s && $2;
2027					#}
2028					#
2029					#sub print_section {
2030					# # the "do" is required for right semantics
2031					# do { $_ = shift(@line) } while !/\S/ && @line;
2032					#
2033					# print("#line ", $line_no[@line_no - @line -1], " \"$filepathname\"\n")
2034					# if $self->{linenumbers} && !/^\s#\sline\b/ && !/^#if XSubPPtmp/;
2035					# for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
2036					# print "$_\n";
2037					# }
2038					# print 'ExtUtils::OOParseXS::CountLines'->end_marker, "\n" if $self->{linenumbers};
2039					#}
2040					#
2041					#sub merge_section {
2042					# my $in = '';
2043					#
2044					# while (!/\S/ && @line) {
2045					# $_ = shift(@line);
2046					# }
2047					#
2048					# for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
2049					# $in .= "$_\n";
2050					# }
2051					# chomp $in;
2052					# return $in;
2053					# }
2054					#
2055					#sub process_keyword($) {
2056					# my($pattern) = @_;
2057					# my $kwd;
2058					#
2059					# no strict 'refs';
2060					# &{"${kwd}_handler"}()
2061					# while $kwd = check_keyword($pattern);
2062					#}
2063
2064					#sub OUTPUT_handler {
2065					# for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
2066					# next unless /\S/;
2067					# if (/^\sSETMAGIC\s:\s(ENABLE\|DISABLE)\s/) {
2068					# $DoSetMagic = ($1 eq "ENABLE" ? 1 : 0);
2069					# next;
2070					# }
2071					# my ($outarg, $outcode) = /^\s(\S+)\s(.?)\s$/s;
2072					# blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
2073					# if $outargs{$outarg} ++;
2074					# if (!$gotRETVAL and $outarg eq 'RETVAL') {
2075					# # deal with RETVAL last
2076					# $RETVAL_code = $outcode;
2077					# $gotRETVAL = 1;
2078					# next;
2079					# }
2080					# blurt ("Error: OUTPUT $outarg not an argument"), next
2081					# unless defined($args_match{$outarg});
2082					# blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
2083					# unless defined $var_types{$outarg};
2084					# $var_num = $args_match{$outarg};
2085					# if ($outcode) {
2086					# print "\t$outcode\n";
2087					# print "\tSvSETMAGIC(ST(" , $var_num-1 , "));\n" if $DoSetMagic;
2088					# }
2089					# else {
2090					# &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic);
2091					# }
2092					# delete $in_out{$outarg} # No need to auto-OUTPUT
2093					# if exists $in_out{$outarg} and $in_out{$outarg} =~ /OUT$/;
2094					# }
2095					#}
2096					#
2097					#sub C_ARGS_handler() {
2098					# my $in = merge_section();
2099					#
2100					# TrimWhitespace($in);
2101					# $func_args = $in;
2102					#}
2103					#
2104					#sub INTERFACE_MACRO_handler() {
2105					# my $in = merge_section();
2106					#
2107					# TrimWhitespace($in);
2108					# if ($in =~ /\s/) { # two
2109					# ($interface_macro, $interface_macro_set) = split ' ', $in;
2110					# }
2111					# else {
2112					# $interface_macro = $in;
2113					# $interface_macro_set = 'UNKNOWN_CVT'; # catch later
2114					# }
2115					# $interface = 1; # local
2116					# $Interfaces = 1; # global
2117					#}
2118					#
2119					#sub INTERFACE_handler() {
2120					# my $in = merge_section();
2121					#
2122					# TrimWhitespace($in);
2123					#
2124					# foreach (split /[\s,]+/, $in) {
2125					# my $name = $_;
2126					# $name =~ s/^$Prefix//;
2127					# $Interfaces{$name} = $_;
2128					# }
2129					# print Q(<<"EOF");
2130					## XSFUNCTION = $interface_macro($ret_type,cv,XSANY.any_dptr);
2131					#EOF
2132					# $interface = 1; # local
2133					# $Interfaces = 1; # global
2134					#}
2135					#
2136					#sub CLEANUP_handler() { print_section() }
2137					#sub PREINIT_handler() { print_section() }
2138					#sub POSTCALL_handler() { print_section() }
2139					#sub INIT_handler() { print_section() }
2140					#
2141					#sub GetAliases {
2142					# my ($line) = @_;
2143					# my ($orig) = $line;
2144					# my ($alias);
2145					# my ($value);
2146					#
2147					# # Parse alias definitions
2148					# # format is
2149					# # alias = value alias = value ...
2150					#
2151					# while ($line =~ s/^\s([\w:]+)\s=\s(\w+)\s//) {
2152					# $alias = $1;
2153					# my $orig_alias = $alias;
2154					# $value = $2;
2155					#
2156					# # check for optional package definition in the alias
2157					# $alias = $Packprefix . $alias if $alias !~ /::/;
2158					#
2159					# # check for duplicate alias name & duplicate value
2160					# Warn("Warning: Ignoring duplicate alias '$orig_alias'")
2161					# if defined $XsubAliases{$alias};
2162					#
2163					# Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$value}' have identical values")
2164					# if $XsubAliasValues{$value};
2165					#
2166					# $XsubAliases = 1;
2167					# $XsubAliases{$alias} = $value;
2168					# $XsubAliasValues{$value} = $orig_alias;
2169					# }
2170					#
2171					# blurt("Error: Cannot parse ALIAS definitions from '$orig'")
2172					# if $line;
2173					#}
2174					#
2175					#sub ATTRS_handler () {
2176					# for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
2177					# next unless /\S/;
2178					# TrimWhitespace($_);
2179					# push @Attributes, $_;
2180					# }
2181					#}
2182					#
2183					#sub ALIAS_handler () {
2184					# for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
2185					# next unless /\S/;
2186					# TrimWhitespace($_);
2187					# GetAliases($_) if $_;
2188					# }
2189					#}
2190					#
2191					#sub OVERLOAD_handler() {
2192					# for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
2193					# next unless /\S/;
2194					# TrimWhitespace($_);
2195					# while ( s/^\s([\w:"\\)\+\-\\/\%\<\>\.\&\\|\^\!\~\{\}\=]+)\s*//) {
2196					# $Overload = 1 unless $Overload;
2197					# my $overload = "$Package\::(".$1;
2198					# push(@InitFileCode,
2199					# " newXS(\"$overload\", XS_$Full_func_name, file$proto);\n");
2200					# }
2201					# }
2202					#}
2203					#
2204					#
2205					#sub SCOPE_handler () {
2206					# death("Error: Only 1 SCOPE declaration allowed per xsub")
2207					# if $scope_in_this_xsub ++;
2208					#
2209					# for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
2210					# next unless /\S/;
2211					# TrimWhitespace($_);
2212					# if ($_ =~ /^DISABLE/i) {
2213					# $ScopeThisXSUB = 0
2214					# }
2215					# elsif ($_ =~ /^ENABLE/i) {
2216					# $ScopeThisXSUB = 1
2217					# }
2218					# }
2219					#}
2220					#
2221					#sub PopFile() {
2222					# return 0 unless $XSStack[-1]{type} eq 'file';
2223					#
2224					# my $data = pop @XSStack;
2225					# my $ThisFile = $filename;
2226					# my $isPipe = ($filename =~ /\\|\s*$/);
2227					#
2228					# -- $IncludedFiles{$filename}
2229					# unless $isPipe;
2230					#
2231					# close $FH;
2232					#
2233					# $FH = $data->{Handle};
2234					# # $filename is the leafname, which for some reason isused for diagnostic
2235					# # messages, whereas $filepathname is the full pathname, and is used for
2236					# # #line directives.
2237					# $filename = $data->{Filename};
2238					# $filepathname = $data->{Filepathname};
2239					# $lastline = $data->{LastLine};
2240					# $lastline_no = $data->{LastLineNo};
2241					# @line = @{ $data->{Line} };
2242					# @line_no = @{ $data->{LineNo} };
2243					#
2244					# if ($isPipe and $? ) {
2245					# -- $lastline_no;
2246					# print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n";
2247					# exit 1;
2248					# }
2249					#
2250					# print Q(<<"EOF");
2251					##
2252					##/* INCLUDE: Returning to '$filename' from '$ThisFile' */
2253					##
2254					#EOF
2255					#
2256					# return 1;
2257					#}
2258					#
2259					#
2260					#sub generate_output {
2261					# my ($type, $num, $var, $do_setmagic, $do_push) = @_;
2262					# my ($arg) = "ST(" . ($num - ($num != 0)) . ")";
2263					# my ($argoff) = $num - 1;
2264					# my ($ntype);
2265					#
2266					# $type = TidyType($type);
2267					# if ($type =~ /^array$([^,]),(.)$/) {
2268					# print "\t$arg = sv_newmortal();\n";
2269					# print "\tsv_setpvn($arg, (char )$var, $2 sizeof($1));\n";
2270					# print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
2271					# }
2272					# else {
2273					# blurt("Error: '$type' not in typemap"),
2274					# return unless defined($type_kind{$type});
2275					# blurt("Error: No OUTPUT definition for type '$type', typekind '$type_kind{$type}' found"),
2276					# return unless defined $output_expr{$type_kind{$type}};
2277					# ($ntype = $type) =~ s/\s\/Ptr/g;
2278					# $ntype =~ s///g;
2279					# ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
2280					# $expr = $output_expr{$type_kind{$type}};
2281					# if ($expr =~ /DO_ARRAY_ELEM/) {
2282					# blurt("Error: '$subtype' not in typemap"),
2283					# return unless defined($type_kind{$subtype});
2284					# blurt("Error: No OUTPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"),
2285					# return unless defined $output_expr{$type_kind{$subtype}};
2286					# $subexpr = $output_expr{$type_kind{$subtype}};
2287					# $subexpr =~ s/ntype/subtype/g;
2288					# $subexpr =~ s/\$arg/ST(ix_$var)/g;
2289					# $subexpr =~ s/\$var/${var}[ix_$var]/g;
2290					# $subexpr =~ s/\n\t/\n\t\t/g;
2291					# $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
2292					# eval "print qq\a$expr\a";
2293					# warn $@ if $@;
2294					# print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic;
2295					# }
2296					# elsif ($var eq 'RETVAL') {
2297					# if ($expr =~ /^\t\$arg = new/) {
2298					# # We expect that $arg has refcnt 1, so we need to
2299					# # mortalize it.
2300					# eval "print qq\a$expr\a";
2301					# warn $@ if $@;
2302					# print "\tsv_2mortal(ST($num));\n";
2303					# print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic;
2304					# }
2305					# elsif ($expr =~ /^\s\$arg\s=/) {
2306					# # We expect that $arg has refcnt >=1, so we need
2307					# # to mortalize it!
2308					# eval "print qq\a$expr\a";
2309					# warn $@ if $@;
2310					# print "\tsv_2mortal(ST(0));\n";
2311					# print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic;
2312					# }
2313					# else {
2314					# # Just hope that the entry would safely write it
2315					# # over an already mortalized value. By
2316					# # coincidence, something like $arg = &sv_undef
2317					# # works too.
2318					# print "\tST(0) = sv_newmortal();\n";
2319					# eval "print qq\a$expr\a";
2320					# warn $@ if $@;
2321					# # new mortals don't have set magic
2322					# }
2323					# }
2324					# elsif ($do_push) {
2325					# print "\tPUSHs(sv_newmortal());\n";
2326					# $arg = "ST($num)";
2327					# eval "print qq\a$expr\a";
2328					# warn $@ if $@;
2329					# print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
2330					# }
2331					# elsif ($arg =~ /^ST$\d+$$/) {
2332					# eval "print qq\a$expr\a";
2333					# warn $@ if $@;
2334					# print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
2335					# }
2336					# }
2337					#}
2338					#
2339					#
2340					##########################################################