#!/usr/bin/perl

# Copyright (C) 2006 Eric L. Wilhelm

use warnings;
use strict;

=head1 NAME

podadz - tool for hacking on pod

=cut

package App::PodAdz;

use warnings;
use strict;

use PPI;
use File::Path;

=head1 Constructor

=head2 new

  $adz = App::PodAdz->new();

=cut
sub new {
	my $caller = shift;
	my $class = ref($caller) || $caller;
	my $self = {@_};
	bless($self, $class);
	return($self);
} # end subroutine new definition
########################################################################

=head1 Dispatch

=head2 lookup_command

  $adz->lookup_command($cmd) or die "cannot run $cmd";

=cut
sub lookup_command {
	my $self = shift;
	my $cmd = shift;
	$cmd or croak("lookup_cmd() requires an argument");
	$cmd = 'cmd_' . $cmd;
	return($self->can($cmd) ? $cmd : '');
} # end subroutine lookup_command definition
########################################################################

=head1 Commands

=head2 cmd_breakout

Break pod sections into named files in $dest_dir.

  $adz->cmd_breakout($source_file, $dest_dir);

=cut
sub cmd_breakout {
	my $self = shift;
	my ($src, $dir) = @_;
	(-e $src) or die;
	mkpath($dir);
	(-d $dir) or die;
	my $doc = PPI::Document->new($src);
	$self->{doc} = $doc;
	# XXX don't really need the indexes
	# $doc->index_locations;

	$self->_index;
	$self->_to_dir($dir);
	## my @chunks;
	## for(my $i = 0; $i < @pods; $i++) {
	## 	my $podbit = $pods[$i];
	## 	# XXX do I dare to revisit basic's line-numbering?
	## 	if(0) {
	## 		$doc->index_locations;
	## 		my $loc = $podbit->location();
	## 		warn "podbit: ", ref($podbit), "\n";
	## 		warn "loc: (@$loc)", ref($loc), "\n";
	## 		## next;
	## 		0 and print _dump_chunk("pod $i, line $loc->[0]", $podbit);
	## 	}
	## }
} # end subroutine cmd_breakout definition
########################################################################

=head2 cmd_assemble

  $adz->cmd_assemble($dest_file, $source_dir);

=cut
sub cmd_assemble {
	my $self = shift;
	my ($src, $dir) = @_;
	(-e $src) or die;
	(-d $dir) or die;
	my $doc = PPI::Document->new($src);
	$self->{doc} = $doc;
	# this is assuming that there is no change to the document from
	# whence the directory was sourced
	$self->_from_dir($dir);
	$self->{doc}->save($src) or die;
} # end subroutine cmd_assemble definition
########################################################################

sub _dump_chunk {
	my ($string, $chunk) = @_;
	return(join('',
		"$string ", "#"x(71-length($string)), "\n",
		$chunk, "\n",
		"#"x72, "\n\n"
		));
} # end subroutine _dump_chunk definition
########################################################################

=begin maintainers

=head2 _ppi_find

Find the pod chunks

  $adz->_ppi_find;

=cut
sub _ppi_find {
	my $self = shift;
	my $doc = $self->{doc} or die;
	my @pods = @{$doc->find(
			sub {
				($_[1]->isa('PPI::Token::Pod')) or return();
			}
		)};
	# XXX keep them?
	## $self->{pods} = \@pods;
	return(@pods);
} # end subroutine _ppi_find definition
########################################################################

=head2 _index

 and break them into indexed pieces.

  $adz->_index;

=cut
sub _index {
	my $self = shift;
	my @pods = $self->_ppi_find;
	if(0) {
		$self->{doc}->index_locations;
		for(my $i = 0; $i < @pods; $i++) {
		 	my $podbit = $pods[$i];
			my $loc = $podbit->location();
	 		print _dump_chunk("pod $i, line $loc->[0]", $podbit);
		}
		exit;
	}
	$self->{indexed} and die;
	$self->{indexed} = [];
	for(my $i = 0; $i < @pods; $i++) {
		my $podbit = "\n\n$pods[$i]";
		my @chunks = split(/\n\n=/, $podbit);
		# the above scheme should leave this null
		# (null is good, this is where "pre" insertions go
		($chunks[0] =~ m/^$/s) or die "eek ($chunks[0])";
		# Can't go before ^=pod though!
		($chunks[1] =~ m/^pod\s*$/s) and shift(@chunks);
		($chunks[-1] =~ m/^cut$/) or die "$chunks[-1] is bad";
		pop(@chunks);
		# XXX how about the ending eol?
		# (I'm thinking handle it on load-in)
		$_ =~ s/\s+$//s foreach @chunks;
		if(0) {
			for(my $n = 0; $n < @chunks; $n++) {
				print _dump_chunk(
					sprintf("chunk: %02d.%02d", $i,$n),
					$chunks[$n] . "\n"
					);
			}
		}
		(@chunks > 100) and die "that's going to hurt";
		push(@{$self->{indexed}}, \@chunks);
	}
} # end subroutine _index definition
########################################################################

=head2 _to_dir

  $adz->_to_dir($dir);

=cut
sub _to_dir {
	my $self = shift;
	my $dir = shift;
	(-d $dir) or die;
	my $ind = $self->{indexed} or die;
	my $format = "%03d.%02d0"; # XXX is that enough?
	for(my $c = 0; $c < @$ind; $c++) {
		for(my $p = 0; $p < @{$ind->[$c]}; $p++) {
			my $chunk = $ind->[$c][$p];
			($chunk =~ m/^$/) and next; # don't write these?
			my ($cname, $rest) = split(/\n+/, $chunk, 2);
			## $rest or warn "no rest for the $cname\n";
			$rest ||= '';
			$cname =~ s/\s+$//;
			$rest = "$cname\n\n" . $rest; # because I gotta have it?

			$cname =~ s/[^a-zA-Z0-9]+/_/g;
			my $fname = sprintf($format, $c, $p) . '-' . $cname;
			## warn "silly filename: $fname\n"; next;
			my $fh;
			open($fh, '>', "$dir/$fname") or
				die "cannot write to '$dir/$fname' $!";
			print $fh "$rest\n";
		}
	}
} # end subroutine _to_dir definition
########################################################################

=head2 _from_dir

  $adz->_from_dir($dir);

=cut
sub _from_dir {
	my $self = shift;
	my $dir = shift;
	(-d $dir) or die;
	my @pods = $self->_ppi_find;
	my @chunks = _read_dir_chunks($dir);
	my $dbg = 0;
	$dbg and warn scalar(@chunks), " chunks\n";
	(@chunks == @pods) or die "now what?";
	for(my $i = 0; $i < @chunks; $i++) {
		my $chunk = $chunks[$i];
		$dbg and warn scalar(@$chunk), " subchunks\n";
		s/\s*$//s for @$chunk;
		$pods[$i]{content} = '=' . join("\n\n=", @$chunk, "cut\n");
	}

} # end subroutine _from_dir definition
########################################################################

=head2 _read_dir_chunks

  @chunks = _read_dir_chunks($dir);

=cut
sub _read_dir_chunks {
	my $dir = shift;
	(-d $dir) or die;
	my $dh;
	opendir($dh, $dir);
	my @files = sort(grep(! /^\./, readdir($dh)));
	my @chunks;
	foreach my $file (@files) {
		my ($num, $else) = split(/-/, $file);
		my ($d,$f) = split(/\./, $num);
		($d =~ m/^\d+$/) or die;
		($f =~ m/^\d+$/) or die;
		$chunks[$d] ||= [];
		{
			my $fh;
			open($fh, "$dir/$file") or die;
			local $/ = undef;
			my $str = <$fh>;
			push(@{$chunks[$d]}, $str);
		}
	}
	return(@chunks);
} # end subroutine _read_dir_chunks definition
########################################################################

=end maintainers;

=cut

package bin::podadz;

use Getopt::Helpful;

sub main {
	my (@args) = @_;
	my $hopt = Getopt::Helpful->new(
		usage => 'CALLER <command> <lib/Foo/Bar.pm> <basedir>',
		'+help',
		);
	$hopt->Get_from(\@args);
	my ($command, $src, $dest);
	foreach my $var ($command, $src, $dest) {
		$var or ($var = shift(@args));
	}
	my $adz = App::PodAdz->new();
	if(my $cmd = $adz->lookup_command($command)) {
		return($adz->$cmd($src, $dest, @args));
	}
	else {
		$hopt->usage("unknown command '$command'");
	}
}

package main;

if($0 eq __FILE__) {
	bin::podadz::main(@ARGV);
}

my $package = 'bin::podadz';