Glib::ParseXSDoc - Parse POD and XSub declarations from XS files.

package Glib::ParseXSDoc;

# vim: set ts=4 :

use strict;
use Data::Dumper;
use Storable qw(store_fd);
use Exporter;
use Carp;

our @ISA = qw(Exporter);
our @EXPORT = qw(
	xsdocparse
);

our $VERSION = '1.003';

our $NOISY = $ENV{NOISYDOC};

sub xsdocparse {
	my @filenames = @_;

	my $parser = Glib::ParseXSDoc->new;
	foreach my $filename (@filenames) {
		$parser->parse_file ($filename);
	}
	$parser->canonicalize_xsubs;
	$parser->swizzle_pods;
	$parser->preprocess_pods;
	$parser->clean_out_empty_pods;

	print "# THIS FILE IS AUTOMATICALLY GENERATED - ANY CHANGES WILL BE LOST\n";
	print "# generated by $0 ".scalar (localtime)."\n";
	print "# input files:\n";
	map { print "#   $_\n" } @filenames;
	print "#\n\n";

	# Data::Dumper converts the whole output to a string, and consequently
	# uses an obscene amount of ram on Gtk2's nearly 200 xs files.  Use
	# Storable unless the user really really wants to force us to fall back
	# to Data::Dumper.  Storable doesn't seem to work well on win32, so
	# always use Data::Dumper there.
	my $use_dd = $ENV{FORCE_DATA_DUMPER} || $^O eq 'MSWin32';
	if ($use_dd) {
		$Data::Dumper::Purity = 1;
		print Data::Dumper->Dump([$parser->{xspods}, $parser->{data}],
		                       [qw($xspods            $data)]);
		print "\n1;\n";
	} else {
		print "use Storable qw(fd_retrieve);\n";
		print "\$xspods = fd_retrieve \\*DATA;\n";
		print "\$data = fd_retrieve \\*DATA;\n";

		print "\n1;\n";
		print "__DATA__\n";

		# NOTE: don't assume STDOUT, because other code may have select'd
		# a different file handle.
		store_fd $parser->{xspods}, select;
		store_fd $parser->{data}, select;
	}

	return [ keys %{$parser->{data}} ];
}

# =========================================================================

our $verbose = undef;

sub new {
	my $class = shift;
	return bless {
		# state
		module => undef,
		package => undef,
		prefix => undef,
		# data
		xspods => [],	#pods for the exported xs interface, e.g. the C stuff
		data => {},	# all the shizzle, by package name
	}, $class;
}

sub package {
		my $self = shift;
		return ($self->{package} || $self->{module})
}

sub pkgdata {
		my $self = shift;
		my $pkg = $self->{object} || $self->package;
		my $pkgdata = $self->{data}{$pkg};
		if (not defined $pkgdata) {
				$pkgdata = {};
				$self->{data}{$pkg} = $pkgdata;
		}
		return $pkgdata;
}

sub parse_file {
	my $self = shift;
	my $filename = shift;

	local *IN;
	open IN, $filename or die "can't open $filename: $!\n";
	print STDERR "scanning $filename\n" if $verbose;
	$self->{filehandle} = \*IN;
	$self->{filename} = $filename;

	# there was once a single state machine to parse an entire
	# file, but it turned into a bi-level state machine because
	# of the two-part nature of XS files.  that's silly, so i've
	# broken it into two loops: the part that scans up to the
	# first MODULE line, and the part that scans the rest of the
	# file.

	my $lastpod = undef;	# most recently-read pod (for next xsub)
	my @thesepackages = ();	# packages seen in this file

	# In the verbatim C portion of the file:
	# seek the first MODULE line *outside* comments.
	# collect any pod we encounter; only certain ones are 
	# precious to us...  my... preciousssss... ahem.
	$self->{module}  = undef;
	$self->{package} = undef;
	$self->{prefix}  = undef;
	$self->{object}  = undef;
	while (<IN>) {
		chomp;
		# in the verbatim C section before the first MODULE line,
		# we need to be on the lookout for a few things...
		# we need the first MODULE line, of course...
		if ($self->is_module_line ($_)) {
			last; # go to the next state machine.

		# mostly we want pods.
		} elsif (/^=/) {
			my $thispod = $self->slurp_pod_paragraph ($_);
			# we're only interested in certain pod directives here.
			if (/^=for\s+(apidoc|object)\b/) {
				my $which = $1;
				warn "$filename:".($.-@{$thispod->{lines}}+1).":"
				   . " =for $which found before "
				   . "MODULE directive\n";
			}
			push @{ $self->{xspods} }, $thispod;

##		# we also need to track whether we're in a C comment, because
##		# MODULE directives are ignore in multiline comments.
##		} elsif (m{/\*}) {
##			# there was an open comment marker on this line.
##			# see if it's alone.
##			s{/\*.*\*/}{}g;
##			if (m{/\*}) {
##				# look for the end...
##				while (<IN>) {
##				}
##			}
		}
	}

	# preprocessor conditionals
	my @cond;

	$lastpod = undef;
	while (<IN>) {
		#
		# we're seeking xsubs and pods to document the Perl interface.
		#
		if ($self->is_module_line ($_)) {
			# xsubs cannot steal pods across MODULE lines.
			$lastpod = undef;

		} elsif (/^\s*$/) {
			# ignore blank lines; but a blank line after a pod
			# means it can't be associated with an xsub.
			$lastpod = undef;

		} elsif (/^\s*#\s*(if|ifdef|ifndef)\s*(\s.*)$/) {
			#warn "conditional $1 $2\n";
			push @cond, $2;
			#print Dumper(\@cond);
		} elsif (/^\s*#\s*else\s*(\s.*)?$/) {
			#warn "else $cond[-1]\n";
			if (exists $cond[$#cond]) {
				$cond[$#cond] = '!' . $cond[$#cond];
			}
		} elsif (/^\s*#\s*endif\s*(\s.*)?$/) {
			#warn "endif $cond[-1]\n";
			pop @cond;
		} elsif (/^\s*#/) {
			# ignore comments.  we've already determined that 
			# this isn't a preprocessor directive (or at least
			# not one in which we're interested).

		} elsif (/^(BOOT|PROTOTYPES)/) {
			# ignore keyword lines in which we aren't interested

		} elsif (/^=/) {
			# slurp in pod, up to and including the next =cut.
			# put it in $lastpod so that the next-discovered
			# xsub can claim it.
			$lastpod = $self->slurp_pod_paragraph ($_);

			# we're interested in certain pod directives at
			# this point...
			if (/^=for\s+object(?:\s+([\w\:]*))?(.*)/) {
				$self->{object} = $1;
				if ($2) {
					$self->pkgdata->{blurb} = $2;
					$self->pkgdata->{blurb} =~ s/^\s*-\s*//;

					# If the line has the special form
					# "=for object Foo (Bar)", we take this
					# to mean: document the object Bar in
					# the file Foo.
					if ($self->pkgdata->{blurb} =~ s/\s*\((.*)\)//)
					{
						print STDERR "Documenting object $1 in file "
									.$self->{object}."\n";
						$self->pkgdata->{object} = $1;
						if ('' eq $self->pkgdata->{blurb})
						{
							delete $self->pkgdata->{blurb};
						}
					}
				}
			} elsif (/^=for\s+(enum|flags)\s+([\w:]+)/) {
				push @{ $self->pkgdata->{enums} }, {
					type => $1,
					name => $2,
					pod => $lastpod,
				};
				# claim this pod now!
				$lastpod = undef;
			} elsif (/^=for\s+see_also\s+(.+)$/) {
				push @{ $self->pkgdata->{see_alsos} }, $1;
				# claim this pod now!
				$lastpod = undef;
			} elsif (/^=for\s+deprecated_by\s+([\w:]+)$/) {
				push @{ $self->pkgdata->{deprecated_bys} }, $1;
				$lastpod = undef;
			}
			push @{ $self->pkgdata->{pods} }, $lastpod
				if defined $lastpod;

		} elsif (/^\w+/) {
			# there's something at the beginning of the line!
			# we've ruled out everything else, so this must be
			# an xsub.  slurp in everything up to the next
			# blank line (or end of file).   i know that's not
			# *really* an entire XSUB body, but we don't care
			# -- we only need the return value, name, arg types,
			# and body type, and there aren't supposed to be 
			# blank lines in all of that.
			my @thisxsub = ($_);
			while (<IN>) {
				chomp;
				last if /^\s*$/;
				push @thisxsub, $_;
			}
			my $xsub = $self->parse_xsub (\@thisxsub);
			if ($lastpod) {
				# aha! we'll lay claim to that...
				pop @{ $self->pkgdata->{pods} };
				$xsub->{pod} = $lastpod;
				$lastpod = undef;
			}
			$xsub->{preprocessor_conditionals} = [ @cond ];
			push @{ $self->pkgdata->{xsubs} }, $xsub;

		} else {
			# this is probably xsub function body, comment, or
			# some other stuff we don't care about.
		}
	}

	# that's it for this file...
	close IN;
	delete $self->{filehandle};
	delete $self->{filename};
}

sub swizzle_pods {
	my $self = shift;
	foreach my $package (keys %{$self->{data}}) {
		my $pkgdata = $self->{data}{$package};
		next unless $pkgdata->{pods};
		next unless $pkgdata->{xsubs};
		my $pods = $pkgdata->{pods};
		for (my $i = @$pods-1 ; $i >= 0 ; $i--) {
			my $firstline = $pods->[$i]{lines}[0];
			next unless $firstline =~ /=for\s+apidoc\s+([:\w]+)\s*/;
			my $name = $1;
			foreach my $xsub (@{ $pkgdata->{xsubs} }) {
				if ($name eq $xsub->{symname}) {
					$xsub->{pod} = $pods->[$i];
					splice @$pods, $i, 1;
					last;
				}
			}
		}
	}
}

sub preprocess_pods {
	my $self = shift;
	foreach my $package (keys %{$self->{data}}) {
		my $pkgdata = $self->{data}{$package};

		foreach (@{$pkgdata->{pods}})
		{
			my $firstline = $_->{lines}[0];
			if ($firstline) {
				$_->{position} = $1 if ($firstline =~ /=for\s+position\s+(\w+)/);
			}
		}

		next unless $pkgdata->{xsubs};

		# look for magic keywords in the =for apidoc
		foreach (@{$pkgdata->{xsubs}})
		{
			my $firstline = $_->{pod}{lines}[0];
			if ($firstline) {
				$_->{function} = ($firstline =~ /__function__/);
				$_->{hidden} = ($firstline =~ /__hide__/);
				$_->{deprecated} = ($firstline =~ /__deprecated__/);
				$_->{gerror} = ($firstline =~ /__gerror__/);
			}
		}
	}
}


# ===============================================================

sub is_module_line {
	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;
	}
}

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,
	};
}

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
						  						  \(              # open paren
						    						    (.*)          # whatever's inside, if anything
						  						  \)              # close paren, maybe with space
						  						  \s*;?\s*$/x) {  # and maybe other junk at the end
		# all on one line
		$xsub{symname} = $2;
		$args = $3;
		my $r = $1;
		$xsub{return_type} = [$r]
			unless $r =~ /^void\s*$/;
		shift @thisxsub; $lineno++;

	} elsif ($thisxsub[1] =~ /^(\S+)\s*\((.*)\);?\s*$/) {
		# multiple lines
		$xsub{symname} = $1;
		$args = $2;
		# return type is on line 0
		$thisxsub[0] =~ s/\s*$//;
		$xsub{return_type} = [$thisxsub[0]]
			unless $thisxsub[0] =~ /^void\s*$/;
		shift @thisxsub; $lineno++;
		shift @thisxsub; $lineno++;
	}

	# eat padding spaces from the arg string.  i tried several ways of
	# building this into the regexen above, but found nothing that still
	# allowed the arg string to be empty, which we'll have for functions
	# (not methods) without resorting to extremely arcane negatory
	# lookbeside assertiveness operators.
	$args =~ s/^\s*//;
	$args =~ s/\s*$//;

	# 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]);
		}
	}

	$SIG{__WARN__} = $oldwarn;

	return \%xsub;
}



sub sanitize_type {
		local $_ = shift;
		s/\s+/ /g;        # squash all whitespace
		s/^\s//;          # zap leading space
		s/\s$//;          # zap trailing space
		s/(?<=\S)\*$/ */; # stars may not be glued to the name
		return $_;
}


sub canonicalize_xsubs {
	my $self = shift;

	return undef unless 'HASH' eq ref $self->{data};

	# make sure that each package contains an xsub hash for each
	# xsub, whether an alias or not.
	foreach my $package (keys %{$self->{data}}) {
		my $pkgdata = $self->{data}{$package};
		next unless $pkgdata or $pkgdata->{xsubs};
		my $xsubs = $pkgdata->{xsubs};
		@$xsubs = map { split_aliases ($_) } @$xsubs;
	}
}

sub split_aliases {
	my $xsub = shift;
	return $xsub unless exists $xsub->{alias};
	return $xsub unless 'HASH' eq ref $xsub->{alias};
	my %aliases = %{ $xsub->{alias} };
	my @xsubs = ();
	my %seen = ();
	foreach my $a (sort { $aliases{$a} <=> $aliases{$b} } keys %aliases) {
		push @xsubs, {
			%$xsub,
			symname => $a,
			pod => undef,
			# we do a deep copy on the args, so that changes to one do not
			# affect another.  in particular, adding docs or hiding an arg
			# in one xsub shouldn't affect another.
			args => deep_copy_ref ($xsub->{args}),
		};
		$seen{ $aliases{$a} }++;
	}
	if (! $seen{0}) {
		unshift @xsubs, $xsub;
	}

	return @xsubs;
}


sub deep_copy_ref {
		my $ref = shift;
		return undef if not $ref;
		my $reftype = ref $ref;
		if ('ARRAY' eq $reftype) {
				my @newary = map { deep_copy_ref ($_) } @$ref;
				return \@newary;
		} elsif ('HASH' eq $reftype) {
				my %newhash = map { $_, deep_copy_ref ($ref->{$_}) } keys %$ref;
				return \%newhash;
		} else {
				return $ref;
		}
}

sub clean_out_empty_pods
{
	my $data = shift;
	return unless (exists ($data->{data}));
	$data = $data->{data};

	my $pod;
	my $xsub;
	foreach (keys %$data)	
	{
		$pod = $data->{$_};
		next if ((exists $pod->{pods} and scalar @{$pod->{pods}}) or
				 exists $pod->{enums} or 
				 scalar (grep (!/DESTROY/, 
								 map { $_->{hidden} 
								       ? ()
									   : $_->{symname} }
								 	@{$pod->{xsubs}})));
		#print STDERR "Deleting $_ from doc.pl's \$data\n";
		delete $data->{$_}; 
	}
}


1;

__END__