view release on metacpan or  search on metacpan

local/lib/perl5/x86_64-linux-thread-multi/Glib/ParseXSDoc.pm  view on Meta::CPAN

	my $self = shift;
	my $l = shift;
	if ($l =~ /^MODULE\s*=\s*([:\w]+)
	            (?:\s+PACKAGE\s*=\s*([:\w]+)
	            (?:\s+PREFIX\s*=\s*([:\w]+))?)?
	            /x) {
		$self->{module}  = $1;
		$self->{package} = $2 || $self->{module};
		$self->{prefix}  = $3;
		$self->{object}  = undef;
		return 1;
	} else {
		return 0;
	}
}


=item $pod = $parser->slurp_pod_paragraph ($firstline, $term_regex=/^=cut\s*/)

Slurp up POD lines from I<$filehandle> from here to the next
I<$term_regex> or EOF.  Since you probably already read a
line to determine that we needed to start a pod, you can pass
that first line to be included.

=cut

sub slurp_pod_paragraph {
	my $parser     = shift;
	my $firstline  = shift;
	my $term_regex = shift || qr/^=cut\s*/o;
	my $filehandle = $parser->{filehandle};

	# just in case.
	chomp $firstline;

	my @lines = $firstline ? ($firstline) : ();
	while (my $line = <$filehandle>) {
		chomp $line;
		push @lines, $line;
		last if $line =~ m/$term_regex/;
	}

	return {
		filename => $parser->{filename},
		line => $. - @lines,
		lines => \@lines,
	};
}


=item $xsub = $parser->parse_xsub (\@lines)

=item $xsub = $parser->parse_xsub (@lines)

Parse an xsub header, in the form of a list of lines,
into a data structure describing the xsub.  That includes
pulling out the argument types, aliases, and code type.

Without artificial intelligence, we cannot reliably 
determine anything about the types or number of parameters
returned from xsubs with PPCODE bodies.

OUTLIST parameters are pulled from the args list and put
into an "outlist" key.  IN_OUTLIST parameters are put into
both.

Data type names are not mangled at all.

Note that the method can take either a list of lines or a reference to a
list of lines.  The flat list form is provided for compatibility; the
reference form is preferred, to avoid duplicating a potentially large list
of strings.

=cut

sub parse_xsub {
	my ($self, @thisxsub) = @_;

	# allow for pass-by-reference.
	@thisxsub = @{ $thisxsub[0] }
	    if @thisxsub == 1 && 'ARRAY' eq ref $thisxsub[0];

	map { s/#.*$// } @thisxsub;

	my $filename = $self->{filename};
	my $oldwarn = $SIG{__WARN__};
#$SIG{__WARN__} = sub {
#		warn "$self->{filename}:$.:  "
#		   . join(" / ", $self->{module}||"", $self->{package}||"")
#		   . "\n    $_[0]\n   ".Dumper(\@thisxsub)
#};

	my $lineno = $. - @thisxsub;
	my %xsub = (
		'filename' => $filename,
		'line' => ($.-@thisxsub),
		'module' => $self->{module},
		'package' => $self->package, # to be overwritten as needed
	);
	my $args;

	#warn Dumper(\@thisxsub);

	# merge continuation lines.  xsubpp allows continuation lines in the
	# xsub arguments list and barfs on them in other spots, but with xsubpp
	# providing such validation, we'll just cheat and merge any that we find.
	# this will bork the line counting logic we have below, but i don't see
	# a fix for it without major tearup of the code here.
	my @foo = @thisxsub;
	@thisxsub = shift @foo;
	while (my $s = shift @foo) {
		if ($thisxsub[$#thisxsub] =~ s/\\$//) {
			chomp $thisxsub[$#thisxsub];
			$thisxsub[$#thisxsub] .= $s;
		} else {
			push @thisxsub, $s;
		}
	}

	if ($thisxsub[0] =~ /^([^(]+\s+\*?)   # return type, possibly with a *
						  \b([:\w]+)\s*   # symbol name

local/lib/perl5/x86_64-linux-thread-multi/Glib/ParseXSDoc.pm  view on Meta::CPAN

	# we can get empty arg strings on non-methods.
	#warn "$filename:$lineno: WTF : args string is empty\n"
	#	if not defined $args;

	my %args = ();
	my @argstr = split /\s*,\s*/, $args;
	#warn Dumper([$args, \%args, \@argstr]);
	for (my $i = 0 ; $i < @argstr ; $i++) {
		# the last one can be an ellipsis, let's handle that specially
		if ($i == $#argstr and $argstr[$i] eq '...') {
			$args{'...'} = { name => '...', };
			push @{ $xsub{args} }, $args{'...'};
			last;
		}
		if ($argstr[$i] =~
		               /^(?:(IN_OUTLIST|OUTLIST)\s+)? # OUTLIST would be 1st
		                 ([^=]+(?:\b|\s))?  # arg type is optional, too
		                 (\w+)              # arg name
		                 (?:\s*=\s*(.+))?   # possibly a default value
		                 $/x) {
			if (defined $1) {
				push @{ $xsub{outlist} }, {
					type => $2,
					name => $3,
				};
				if ($1 eq 'IN_OUTLIST') {
					# also an arg
					$args{$3} = {
						type => $2,
						name => $3,
					};
					$args{$3}{default} = $4 if defined $4;
					push @{ $xsub{args} }, $args{$3};
				}
			
			} else {
				$args{$3} = {
					type => $2,
					name => $3,
				};
				$args{$3}{default} = $4 if defined $4;
				push @{ $xsub{args} }, $args{$3};
			}
		} elsif ($argstr[$i] =~ /^g?int\s+length\((\w+)\)$/) {
			#warn " ******* $i is string length of $1 *****\n";
		} else {
			warn "$filename:$lineno: ($xsub{symname}) don't know how to"
			   . " parse arg $i, '$argstr[$i]'\n";
		}
	}

	

	my $xstate = 'args';
	while ($_ = shift @thisxsub) {
		if (/^\s*ALIAS:/) {
			$xstate = 'alias';
		} elsif (/\s*(PREINIT|CLEANUP|OUTPUT|C_ARGS):/) {
			$xstate = 'code';
		} elsif (/\s*(PPCODE|CODE):/) {
			$xsub{codetype} = $1;
			last;
		} elsif ($xstate eq 'alias') {
			/^\s*([:\w]+)\s*=\s*(\d+)\s*$/;
			if (defined $2) {
				$xsub{alias}{$1} = $2;
			} else {
				warn "$filename:$lineno: WTF : seeking alias on line $_\n";
			}
		} elsif ($xstate eq 'args') {
			if (/^\s*
			      (.+(?:\b|\s))      # datatype
			      (\w+)              # arg name
			      ;?                 # optional trailing semicolon
			      \s*$/x)
			{
				if (exists $args{$2}) {
					$args{$2}{type} = $1
				} else {
					warn "$filename:$lineno: unused arg $2\n";
					warn "  line was '$_'\n";
				}
			} elsif (/^\s*/) {
				# must've stripped a comment.
			} else {
				warn "$filename:$lineno: WTF : seeking args on line $_\n";
			}
		}
		$lineno++;
	}

	# mangle the symbol name from an xsub into its actual perl name.
	$xsub{original_name} = $xsub{symname};
	if (defined $self->{prefix}) {
		my $pkg = $self->package;
		$xsub{symname} =~ s/^($self->{prefix})?/$pkg\::/;
	} else {
		$xsub{symname} = ($self->package)."::".$xsub{symname};
	}

	# sanitize all the C type declarations, which we have 
	# collected in the arguments, outlist, and return types.
	if ($xsub{args}) {
		foreach my $a (@{ $xsub{args} }) {
			$a->{type} = sanitize_type ($a->{type})
				if defined $a->{type};
		}
	}
	if ($xsub{outlist}) {
		foreach my $a (@{ $xsub{outlist} }) {
			$a->{type} = sanitize_type ($a->{type})
				if defined $a->{type};
		}
	}
	if ($xsub{return_type}) {
		for (my $i = 0 ; $i < @{ $xsub{return_type} } ; $i++) {
			$xsub{return_type}[$i] =
				sanitize_type ($xsub{return_type}[$i]);
		}
	}