File Coverage

blib/lib/POD/Generate.pm

Criterion	Covered	Total	%
statement	211	228	92.5
branch	56	74	75.6
condition	35	57	61.4
subroutine	45	51	88.2
pod	29	33	87.8
total	376	443	84.8

package POD::Generate;
use 5.006; use strict; use warnings; our $VERSION = q|0.01|;

use overload
	q|${}| => sub { $_[0]->generate(q|string|) },
	fallback => 1;

sub new {
	my $class = shift;
   	my $self = bless @_ ? @_ > 1 ? {@_} : {%{$_[0]}} : {}, ref $class || $class;
	$self->{pod} ||= {};
	$self->{width} ||= 100;
	return $self;
}

sub pod { $_[0]->{pod} }

sub start { name(@_) }

sub end { generate(@_) }

sub name {
	my ($self, $name, $abbr) = @_;
	$self->pod->{$name} = __PACKAGE__->new(name => $name, width => $self->{width}, pod => []);
	push @{ $self->pod->{$name}->pod }, {
		identifier => q|head1|,
		title => q|NAME|,
		content =>  $name . ($abbr ? (q| - | . $abbr) : q||)
	};
	return $self->{pod}->{$name};
}

sub generate {
	my ($self, $type) = @_;
	if (ref $self->pod eq q|HASH|) {
		my %out;
		for my $key (keys %{$self->pod}) {
			$out{$key} = $self->pod->{$key}->generate();
		}
		return \%out;
	}
	$type ||= q|string|;
	my $last_identifier = _last_identifier($self);
	push @{$self->{pod}}, {
		identifier => q|back|
	} if ($last_identifier =~ m/item|over/);
	push @{$self->pod}, {
		identifier => q|cut|
	} if ($last_identifier !~ m/none|cut/);
	my $pod = q||;
	$pod .=	$self->generate_pod_section($_) for (@{ $self->pod });
	my $method = sprintf(q|to_%s|, $type);
	$self->$method($pod || q|empty|);
}

sub add {
	my ($self, $identifier, $title, $content) = @_;
	my $has_ident = defined $identifier;
	if (defined $content && ($identifier || "p") ne 'v' && $self->{width}) {
		my @chars = split "", $content;
		my $die = 0;
		my ($string, $length) = ('',  0);
		while (@chars) {
			my $i = 0;
			$i++ while (defined $chars[$i] && $chars[$i] !~ m/(\s|\n)/);
			$length = 0 if ($i == 0 && $chars[$i] =~ m/\n/);
			$i ||= 1;
			($length + $i <= $self->{width}) ? do {
				$string .= join "", splice @chars, 0, $i || 1;
				$length += $i;
			} : do {
				$string .= "\n" . join "", splice @chars, 0, $i || 1;
				$string =~ s/\s$//i && $i--;
				$length = $i;
			};
		}
		$content = $string;
	} elsif ($has_ident && $identifier eq 'v') {
		$identifier = $has_ident = undef;
	}

	if ($has_ident) {
		if ($identifier eq q|item|) {
			if (_last_identifier($self) !~ m/item|over/) {
				push @{$self->{pod}}, {
					identifier => q|over|
				};
			}
		} else {
			my $last_identifier = _last_identifier($self);
			if ($last_identifier =~ m/item|over/) {
				push @{$self->{pod}}, {
					identifier => q|back|
				};
			}
			push @{$self->{pod}}, {
				identifier => q|cut|
			} if ($last_identifier !~ m/cut/);
		}
	}
	push @{ $self->{pod} }, {
		(defined $identifier ? (identifier => $identifier) : ()),
		(defined $title ? (title => $title) : ()),
		(defined $content ? (content => $content) : ())
	};
}

sub p {
	my $self = shift;
	$self->add(undef, undef, @_);
	$self;
}

sub v {
	my $self = shift;
	$self->add('v', undef, @_);
	$self;
}

sub h1 {
	my $self = shift;
	$self->add(q|head1|, @_);
	$self;
}

sub h2 {
	my $self = shift;
	$self->add(q|head2|, @_);
	$self;
}

sub h3 {
	my $self = shift;
	$self->add(q|head3|, @_);
	$self;
}

sub h4 {
	my $self = shift;
	$self->add(q|head4|, @_);
	$self;
}

sub item {
	my $self = shift;
	$self->add(q|item|, @_);
	$self;
}

sub version {
	my $self = shift;
	$self->add(q|head1|, q|VERSION|, $self->_default_version_cb(@_));
	$self;
}

sub description {
	my $self = shift;
	$self->add(q|head1|, q|DESCRIPTION|, $self->_default_description_cb(@_));
	$self;
}

sub synopsis {
	my $self = shift;
	$self->add(q|head1|, q|SYNOPSIS|, undef);
	$self->add(q|v|, undef,  $self->_default_synopsis_cb(@_));
	$self;
}

sub methods {
	my $self = shift;
	$self->add(q|head1|, q|METHODS|, $self->_default_methods_cb(@_));
	$self;
}

sub exports {
	my $self = shift;
	$self->add(q|head1|, q|EXPORTS|, $self->_default_exports_cb(@_));
	$self;
}

sub footer {
	my ($self, %args) = @_;
	$self->formatted_author($args{name}, $args{email})
		->bugs($args{bugs})
		->support($args{support}, @{$args{support_items}})
		->acknowledgements($args{acknowledgements})
		->license($args{license}, $args{name});
	$self;
}

sub author {
	my $self = shift;
	$self->add(q|head1|, q|AUTHOR|, $self->_default_author_cb(@_));
	$self;
}

sub formatted_author {
	my ($self, $name, $email) = @_;
	$email =~ s/\@/ at /g;
	$self->add(q|head1|, q|AUTHOR|, sprintf(q|%s, C<< <%s> >>|, $name, $email));
	$self
}

sub bugs {
	my ($self, $content) = @_;
	$self->add(q|head1|, q|BUGS|, $self->_default_bugs_cb($content));
	$self;
}

sub support {
	my ($self, $content, @items) = @_;
	$self->add(q|head1|, q|SUPPORT|, $self->_default_support_cb($content));
	@items = $self->_default_support_items_cb(@items);
	$self->add(q|item|, @{$_}) for (@items);
	$self;
}

sub _default_version_cb {
	my ($self) = shift;
	return $self->{version_cb} && $self->{version_cb}->($self, @_) || @_;
}

sub _default_description_cb {
	my ($self) = shift;
	return $self->{description_cb} && $self->{description_cb}->($self, @_) || @_;
}

sub _default_synopsis_cb {
	my ($self) = shift;
	return $self->{synopsis_cb} && $self->{synopsis_cb}->($self, @_) || @_;
}

sub _default_methods_cb {
	my ($self) = shift;
	return $self->{methods_cb} && $self->{methods_cb}->($self, @_) || @_;
}

sub _default_exports_cb {
	my ($self) = shift;
	return $self->{exports_cb} && $self->{exports_cb}->($self, @_) || @_;
}

sub _default_author_cb {
	my ($self) = shift;
	return $self->{author_cb} && $self->{author_cb}->($self, @_) || @_;
}

sub _default_bugs_cb {
	my ($self, $content) = @_;
	return $self->{bugs_cb}
		? $self->{bugs_cb}->($self, $content)
		: defined $content
			? $content
			: $self->_default_bugs_content();
}

sub _default_bugs_content {
	my ($self) = @_;
	(my $formatted_name = $self->{name}) =~ s/\:\:/\-/g;
	my $content = sprintf(
		qq|Please report any bugs or feature requests to C, or through\n|,
		lc($formatted_name)
	);
	$content .= sprintf(
		qq|the web interface at L. I will\n|,
		$formatted_name
	);
	$content .= q|be notified, and then you'll automatically be notified of progress on your bug as I make changes.|;
	return $content;
}

sub _default_support_cb {
	my ($self, $content) = @_;
	return $self->{support_cb}
		? $self->{support_cb}->($self, $content)
		: defined $content
			? $content
			: $self->_default_support_content();
}

sub _default_support_content {
	my ($self) = @_;
	my $content = q|You can find documentation for this module with the perldoc command.|;
	$content .= sprintf(qq|\n\n	perldoc %s\n\n|, $self->{name});
	$content .= q|You can also look for information at:|;
	return $content;
}

sub _default_support_items_cb {
	my ($self, @items) = @_;
	return $self->{support_items_cb}
		? $self->{support_items_cb}->($self, @items)
		: scalar @items
			? @items
			: $self->_default_support_items();
}

sub _default_support_items {
	my ($self) = @_;
	my @items = ();
	(my $formatted_name = $self->{name}) =~ s/\:\:/\-/g;
	push @items, [
		q|* RT: CPAN's request tracker (report bugs here)|,
		sprintf(q|L|, $formatted_name)
	];
	push @items, [
		q|* CPAN Ratings|,
		sprintf(q|L|, $formatted_name)
	];
	push @items, [
		q|* Search CPAN|,
		sprintf(q|L|, $formatted_name)
	];
	return @items;
}

sub acknowledgements {
	my $self = shift;
	$self->add(q|head1|, q|ACKNOWLEDGEMENTS|, $self->default_acknowledgements_cb(@_));
	$self;
}

sub default_acknowledgements_cb {
	my ($self) = shift;
	return $self->{acknowledgements_cb} && $self->{acknowledgements_cb}->($self, @_) || @_;
}

sub license {
	my ($self, $license, $name) = @_;
	$self->add(q|head1|, q|LICENSE AND COPYRIGHT|, $self->default_license_cb($license, $name));
}

sub default_license_cb {
	my ($self, $license, $name) = @_;
	return $self->{license_cb}
		? $self->{license_cb}->($self, $license, $name)
		: defined $license
			? $license
			: $self->default_license_content($name);
}

sub default_license_content {
	my ($self, $author) = @_;
	my $content = sprintf(qq|This software is Copyright (c) 2022 %s\n\n|, $author || q|by the author|);
	$content .= q|This is free software, licensed under:|;
	$content .= qq|\n\n	The Artistic License 2.0 (GPL Compatible)|;
}

sub generate_pod_section {
	my ($self, $section) = @_;
	my $pod = q||;
	$pod .= sprintf(qq|\n\n=%s|, $section->{identifier}) if $section->{identifier};
	$pod .= sprintf(q| %s|, $section->{title}) if $section->{title};
	$pod .= sprintf(qq|\n\n%s|, $section->{content}) if $section->{content};
	return $pod;
}

sub to_string {
	my ($self, $string) = @_;
	return $_[0]->generate(q|string|) if (!$string);
	$string =~ s/^\n*//g;
	return $string;
}

sub to_file {
	my ($self, $string) = @_;
	return $_[0]->generate(q|file|) if (!$string);
	(my $file = $self->{name}) =~ s/\:\:/\//g;
	$file .= '.pm';
	require $file;
	$file = $INC{$file};
        open my $fh, "<", $file or die "Cannot open file for read/writing $file";
        my $current = do { local $/; <$fh> };
        close $fh;
        die "no \_\_END\_\_ to code bailing on writing to the .pm file" unless $current =~ s/(\_\_END\_\_).*/$1/xmsg;
        $current .= $string;
        open my $wh, ">", $file;
        print $wh $current;
	close $wh;
	return $string;
}

sub to_seperate_file {
	my ($self, $string) = @_;
	return $_[0]->generate(q|seperate_file|) if (!$string);
	(my $file = $self->{name}) =~ s/\:\:/\//g;
	$file .= '.pm';
	require $file;
	$file = $INC{$file};
       	$file =~ s/pm$/pod/;
	$string =~ s/^\n*//g;
	open my $wh, ">", $file;
        print $wh $string;
	close $wh;
	return $string;
}

sub _last_identifier {
	my $self = shift;
	my ($i, $last_identifier) = -1;
	$self->{pod}->[$i]
		? $self->{pod}->[$i]->{identifier}
			? do { $last_identifier = $self->{pod}->[$i]->{identifier}; 1 }
			: $i--
		: do { $last_identifier = q|none|; }
	while (!$last_identifier);
	return $last_identifier;
}


1;

__END__