#!/usr/bin/perl

use strict;
use warnings;
use IO::Socket::INET; # The server
use File::Spec; # For finding files
# use File::FlockDir qw(open close flock $Assume_LockDir_Zombie_Minutes); # For locking log file remove on OSs serporting Flock
use Date::Format;

our $VERSION="0.2.392";

=head1 NAME

POD Server.

=cut

=head2 Config

The config settings you can use these are set in the script file for now.

=over 4
=cut

my $config; # Holds all config info.
$config->{Port} = "8080";

=item Port

The port that the server should listen on.

=cut

$config->{Index}->{File} = "index.pod"; # Where to save the index file # And get it some of the time
$config->{Index}->{On} = 1;
$config->{Index}->{Url} = "index";
$config->{Index}->{PerSlaves} = 16;
$config->{Index}->{GroupSize} = 2;

=item Index

Contains info on the index file

=item Index->File

The file to use for generating and returning an index.

=item Index->On

Wether to make an index or not.

=item Index->Url

The file name of the index as seen by the world.

=item Index->PerlSlaves

Make a new index arfter this many slaves die.
An index is made when the server starts

=item Index->GroupeSize

This is the number of letters which you whant to use from the beging of the page name I recomend 1 or 2.

=cut

# $config->{PodDirs}->[0] = '/usr/lib/perl5';
$config->{UseINC} = 1;

=item PodDirs

Contains the dirs that have pod files

=item PodDirs->@

An array of dirs to look for pod files in.
POD Server will look for them in the order of the array

=item UseINC

If set to true POD Server will append the @inc array to the PodDirs array.

=cut

$config->{PodExt}->[0] = ".pod";
$config->{PodExt}->[1] = ".pm";
$config->{PodExt}->[2] = ".pl";
$config->{PodExt}->[3] = ".plx";
$config->{PodExt}->[4] = ".al";
$config->{PodExt}->[5] = ".cgi";

=item PodExt

An array of pod extenshions to use in the order of the array.

=cut

$config->{Style}->{Norm}->{mime} = "text/plain";

$config->{Style}->{raw}->{mine} = "text/plain";
$config->{Style}->{raw}->{on} = 1;

$config->{Style}->{pod}->{mine} = "text/plain";
$config->{Style}->{pod}->{on} = 1;

$config->{Style}->{html}->{mine} = "text/html";
$config->{Style}->{html}->{on} = 1;
$config->{Style}->{html}->{Script} = "pod2html";
$config->{Style}->{html}->{PodRoot} = '';

$config->{Style}->{text}->{mine} = "text/plain";
$config->{Style}->{text}->{on} = 1;
$config->{Style}->{text}->{Script} = "pod2text";

$config->{Style}->{xml}->{mine} = "text/plain";
$config->{Style}->{xml}->{on} = 1;
$config->{Style}->{xml}->{Script} = "pod2xml";

$config->{Style}->{man}->{mine} = "text/plain";
$config->{Style}->{man}->{on} = 1;
$config->{Style}->{man}->{Script} = "pod2man";

$config->{Style}->{pdf}->{mine} = "application/pdf";
$config->{Style}->{pdf}->{on} = 1;
$config->{Style}->{pdf}->{Script} = "pod2pdf";

$config->{Style}->{textc}->{mine} = "text/plain";
$config->{Style}->{textc}->{on} = 1;
$config->{Style}->{textc}->{Script} = "pod2text";

=item Style

This contains all the style information.

The data is split into gropes one for each style and a B<Norm> for defolts.

Each group can have these settings and possible others.
=over 8

=item * mime

The mime of the file type eg C<text/html> or C<text/plain>.

=item * on

A true, false value stating whether to use this option or return an empty file

=item * Script

The file name of the script which does the converting.

=back

The following are curently serported formats.

=over 8

=item * raw

All of the file like a web server.
This is a sercurity risk

=item * pod

Just the pod bits of the file.

=item * html

The file converted to html

=item * text

Plain text

=item * xml

The file converted to xml

=item * man

The file is converted to man page format

=item * pdf

Pdf vershion of the file.

=item * textc

A Colour text vershion of the file

=back

=cut

$config->{DStyle} = "html";

=item DStyle

The normal style to use when nune has been spesified.

=cut

$config->{Slaves} = 2;

=item Slaves

The number of slaves to fork to handle requests.
This is not the number of proses that will be running as most formats run external programs and the server may fork another proses to make the index.

=cut

$config->{ConsPerSlave} = 8;

=item ConsPerSlave

The number of connections each slave should run before dieing and being repliced

=cut

$config->{Fork} = 0;

=item Fork

A true false value on wethere to us C<fork> function.
I added this because I keep getting invalid page folts when one of the proses dye on windows
If you can help me with this let me know what I am doing wong.

=cut

$config->{PerlExe} = '/usr/bin/perl';

=item PerlExe

This is used by some of the formats to run perl scripts.
It should be the full parth to your perl exe.

=cut

$config->{TempDir} = '/tmp';

=item TempDir

The temp directory that holds all temp files.
They should be removed but this is may not happen so you should have it some where where files will be deleated arter a shourt time.

=cut

$config->{log}->{File} = "pod.log";
$config->{log}->{ToFile} = 1;
$config->{log}->{ToStderr} = 1;
$config->{log}->{ToStdout} = 0;

=item log

Contains login information

=item log->File

The file to log to

=item log->ToFile

A true false value stating whether to send loging info to the log file

=item log->ToStderr

A true false value stating whether to send loging info to STDERR

=item log->ToStdout

A true false value stating whether to send loging info to STDOUT

=back

=cut

my $nl = "\015\012";
my %server; # Holds pids of servers
$| = 1;

# $Assume_LockDir_Zombie_Minutes = 1; # Stop log from getting stuck. # Remove on Mershens with flock

# LOCK_SH = 1; # Note to self
# LOCK_EX = 2;
# LOCK_NB = 4;
# LOCK_UN = 8;

my %log = (
	server_no => 0,
	con_no => 0,
);

my $server = IO::Socket::INET->new(
	LocalPort => $config->{Port},
	Listen => SOMAXCONN,
) or &logthis(
	message => "Could not start server $!",
	fatal =>  1,
	%log
);

&logthis(
	message => "Server started",
	%log,
);

if ($config->{UseINC}){
	push(@{$config->{PodDirs}}, @INC);
}

if ($config->{Fork}){
	foreach (1..$config->{Slaves}){ # Pree Fork
		&forkit($_);
	}
	while (1){
		if ($config->{Index}->{On}){ # Make index
			if (my $pid = fork){}
			else {
				&mkindex();
				exit;
			}
		}
		foreach (1..$config->{Index}->{PerSlaves}){ # Refork slaves
			my $pid = wait;
			my $server_no = $server{$pid};
			&forkit($server_no);
		}
	}
}
else{
	my $server_no; # Count servers
	while (1){
		if ($config->{Index}->{On}){&mkindex();} # Make index
		foreach (1..$config->{Index}->{PerSlaves}){ # Parse connections
			$server_no++;
			&connection($server_no);
		}
	}
}

sub logthis{ # I do not want to hide log.
	# 0 Logging failed
	# 1 All OK
	# 2 Not logging all ok
	my @arg = @_;
	if ($config->{log}->{ToFile} || $config->{log}->{ToStderr}){
		foreach (@arg){
			s/\012|\015//g;
		}
		my %set = @arg;
		my $ip = join(".", unpack("CCCC", $set{ip} || "\0\0\0\0"));
		my $ident = $set{ident} || "-";
		my $user = $set{user} || "-";
		my $time = time2str("%d/%b/%Y:%T %z", time);
		my $request = $set{request} || "-";
		my $status = $set{status} || "-";
		my $size = $set{size} || "-";
		# Extras
		my $file = $set{file} || "-";
		my $format = $set{format} || "-";
		my $message = $set{message} || "-";
		my $server_no = $set{server_no} || "-";
		my $con_no = $set{con_no} || "-";
		my $logline = "$ip $ident $user [$time] \"$request\" $status $size $file \"$message\" $server_no $con_no\n";
		if ($config->{log}->{ToFile}){
			open(LOG, ">>$config->{log}->{File}") or return 0;
			flock(LOG, 2) or return 0;
			my $oldfh = select LOG;
			$| = 1;
			select $oldfh;
			seek(LOG, 0, 2);
			print LOG $logline;
			close LOG;
		}
		if ($config->{log}->{ToStderr}){
			my $oldfh = select STDERR;
			$| = 1;
			select $oldfh;
			print STDERR $logline;
		}
		if ($config->{log}->{ToStdout}){
			my $oldfh = select STDOUT;
			$| = 1;
			select $oldfh;
			print STDOUT $logline;
		}
		if ($set{fatal}){
			exit;
		}
		return 1;
	}
	else {
		return 2; # A true value but not one because no log was made
	}
}

sub forkit{
	my $server_no = shift;
	if (my $pid = fork){
		$server{$pid} = $server_no;
		sleep(1);
		return 1;
	}
	else{
		&connection($server_no);
		sleep(1);
		exit;
	}
}

sub connection{
	my $server_no = shift;
	SERVER:foreach my $con_no(1..$config->{ConsPerSlave}){
		my $client = $server->accept(); # Items needed for the connection
		my %log;
		CONNECTION:{
			$log{server_no} = $server_no;
			$log{con_no} = $con_no;
			my $con;
			$log{ip} = $client->peeraddr();
			my $request = <$client>;
			$log{request} = $request;
			($con->{method}, $con->{url}, $con->{proto}) = $request =~ m/^(\S+)\s+(\S+)\s+(\S+)\s*$/ or eval{
				# No bad request lines
				$log{message} .= "Request error";
				print $client "HTTP/1.1 400 Bad Request", $nl;
				print $client "Date: ", gmtime(), $nl;
				print $client $nl;
				$log{status} = 400;
				last CONNECTION;
			};
			unless ($con->{method} =~ m/get/i){ # Only alow get requests
				print $client "HTTP/1.1 501 Not Implemented", $nl;
				print $client "Date: ", gmtime(), $nl;
				print $client $nl;
				$log{status} = 501;
				last CONNECTION;
			}
			($con->{url}, $con->{query}) = split(/\?/, $con->{url});
			while ($con->{url} =~ s/\.\.//g){1} # remove double dots to prevent hacks all of them
			$con->{format} = $con->{query} || $config->{DStyle}; # Find out what style to use
			if ($con->{url} eq "/"){ # Did they not state a file then return the index.
				$con->{url} = $config->{Index}->{Url};
			}
			WHICH_FILE:{
				# Witch file
				my $file;
				if ($con->{url} =~ m/^(.*)\./){ # Nead big (.*) so only extenshion removed and not file name
					$file = $1;
				}
				else{
					$file = $con->{url};
				}
				$file =~ s/^\\\///g; # Remove leading slashes no route file hear
				unless ($file){
					$log{message} .= "No file";
					print $client "HTTP/1.1 500 Internal Server Error", $nl;
					print $client "Date: ", gmtime(), $nl;
					print $client $nl;
					$log{status} = 501;
					last CONNECTION;
				}
				foreach my $t_dir(@{$config->{PodDirs}}){
					foreach my $t_ext(@{$config->{PodExt}}){
						my $t_file = $t_dir . File::Spec->catfile(split(/\/+|:+/, $file . $t_ext));
						if (-e $t_file && -r _){
							$con->{podfile} = $t_file;
							$log{file} .= $t_file;
							last WHICH_FILE;
						}
					}
				}
				unless ($con->{podfile}){
					print $client "HTTP/1.1 404 Not Found", $nl;
					print $client "Date: ", gmtime(), $nl;
					my $mime = $config->{Style}->{$con->{format}}->{mine} || $config->{Style}->{Norm}->{mime};
					print $client "Content-Type: ", $mime, $nl;
					print $client $nl;
					if (-e $config->{Index}->{File} && -r _){
						$log{status} = 404;
						$log{file} .= $config->{Index}->{File};
						$con->{podfile} = $config->{Index}->{File};
						goto FORMAT; # Go and get the index know to show with 404 error.
					}
					else {
						last CONNECTION; # Nothing else possible so give up.
					}
				}
			}
			print $client "HTTP/1.1 200 OK", $nl;
			print $client "Date: ", gmtime(), $nl;
			my $mime = $config->{Style}->{$con->{format}}->{mine} || $config->{Style}->{Norm}->{mime};
			print $client "Content-Type: ", $mime, $nl;
			print $client "Sever: PodServer/2.0 (perl/$^O)", $nl;
			print $client $nl;
			$log{status} = 200;
			FORMAT:foreach my $t_format(1..2){
				#  \/ Use these vars should not change much
				my $format = $con->{format};
				my $file = $con->{podfile};
				my $fh = $client;
				if ($format =~ m/html/i){
					if ($config->{Style}->{html}->{on}){
						# Used open instead of qx so that data is returned to the user quicker to start.
						my $command = "$config->{PerlExe} $config->{Style}->{html}->{Script} --infile=$file --htmlroot=/ --quiet";
						open(PIPE, "$command|");
						while ($_ = <PIPE>){
							print $fh $_;
						}
						close PIPE;
						$log{format} = "HTML";
					}
					last FORMAT;
				}
				elsif ($format =~ m/text/i){
					if ($config->{Style}->{html}->{on}){
						my $command = "$config->{PerlExe} $config->{Style}->{text}->{Script} $file";
						open(PIPE, "$command|");
						while ($_ = <PIPE>){
							print $fh $_;
						}
						close PIPE;
						$log{format} = "TEXT";
					}
					last FORMAT;
				}
				elsif ($format =~ m/textc/i){
					if ($config->{Style}->{textc}->{on}){
						my $command = "$config->{PerlExe} $config->{Style}->{textc}->{Script} -c $file";
						open(PIPE, "$command|");
						while ($_ = <PIPE>){
							print $fh $_;
						}
						close PIPE;
						$log{format} = "TEXTC";
					}
					last FORMAT;
				}
				elsif ($format =~ m/pdf/i){
					if ($config->{Style}->{pdf}->{on}){
						`$config->{PerlExe} $config->{Style}->{pdf}->{Script} $file`;
						my $pdf = $file . ".pdf";
						open(TMP, "<$pdf") or last FORMAT;
						seek(TMP, 0, 0); # No errors please use TMP more than once
						while (<TMP>){
							print $fh $_;
						}
						close TMP;
						unlink $pdf;
						$log{format} = "PDF";
					}
					last FORMAT;
				}
				elsif ($format =~ m/xml/i){
					if ($config->{Style}->{xml}->{on}){
						my $command = "$config->{PerlExe} $config->{Style}->{xml}->{Script} $file";
						open(PIPE, "$command|");
						while ($_ = <PIPE>){
							print $fh $_;
						}
						close PIPE;
						$log{format} = "XML";
					}
					last FORMAT;
				}
				elsif ($format =~ m/man/i){
					if ($config->{Style}->{man}->{on}){
						my $command = "$config->{PerlExe} $config->{Style}->{man}->{Script} $file";
						open(PIPE, "$command|");
						while ($_ = <PIPE>){
							print $fh $_;
						}
						close PIPE;
						$log{format} = "MAN";
					}
					last FORMAT;
				}
				elsif ($format =~ m/pod/i){
					if ($config->{Style}->{pod}->{on}){
						open(POD, "<$file");
						flock(POD, 1);
						while (<POD>){
							unless (/^=/){next}
							if (/^=/){
								print $fh $_;
								while (<POD>){
									if (/^=cut/){last}
									print $fh $_;
								}
							}
						}
						$log{format} = "POD";
					}
					last FORMAT;
				}
				elsif ($format =~ m/raw/i){
					if ($config->{Style}->{raw}->{on}){
						open(POD, "<$file");
						flock(POD, 1);
						while (<POD>){
							print $fh $_;
						}
						close POD;
						$log{format} = "RAW";
					}
					last FORMAT;
				}
				# Template
				#elsif ($format =~ m/raw/i){
				#	if ($config->{Style}->{raw}->{on}){
				#		# Put code hear
				#		# Get settings from $config
				#		$log{format} = "HTML";
				#	}
				#	last FORMAT;
				#}

				else {
					if ($t_format == 1){
						$format = $config->{DStyle};
					}
					else {
						$log{message} .= "Bad format $format";
						last CONNECTION;
					}
				}
			}
		}
		close $client;
		&logthis(%log) or warn "Logging error\n";
	}
	return 256;
}
sub mkindex{
	our @index;
	my %log = (
		server_no => 0,
		con_no => 1,
		message => "New Index",
	);
	foreach (@{$config->{PodDirs}}){
		my $indent = 0;
		&parsedir($_);
	}
	sub parsedir{
		my $dir = shift;
		my @stack = @_;
		opendir(my $dh, $dir) or warn "can not open $dir: $!";
		FILE:while (my $file = readdir($dh)){
			if ($file =~ m/^\./){next FILE}
			my $file_long = File::Spec->catfile($dir, $file);
			if (-f $file_long){
				foreach (@{$config->{PodExt}}){
					if ($file =~ m/(.*)$_/){
						push(@index, join("::", @stack, $1));
						next FILE;
					}
				}
				next FILE;
			}
			if (-d $file_long){
				$file_long =~ s/\\/\\/go;
				&parsedir($file_long, @stack, $file);
			}
		}
		close $dh;
	}
	@index = sort{lc($a) cmp lc($b)} @index;
	unless (open(INDEX, ">$config->{Index}->{File}")){
		$log{message} = "Can not open Log file $!";
		return 0;
	}
	flock(INDEX, 2);
	my $oldfh = select INDEX;
	$| = 1;
	select $oldfh;
	print INDEX "=head1 Index\n\n";
	print INDEX "=over 4\n\n";
	my @ol;
	my $indexlets = $config->{Index}->{GroupSize}-1;
	foreach (@index){
		if ($_){
			my @nl = split("", $_);
			my $changed = 0;
			foreach (0..$indexlets){
				unless (lc($nl[$_]) eq lc($ol[$_])){
					$ol[$_] = uc($nl[$_]);
					$changed++;
				}
			}
			if ($changed){
					print INDEX "\n\n=head2 " . join("", @ol[0..$indexlets]) . "\n\n";
				}
			print INDEX "L<$_|$_>, ";
		}
	}
	print INDEX "\n\n=back\n\n";
	print INDEX "=cut\n\n";
	close INDEX;
	&logthis(%log);
	return 1;
}

=head1 SYNOPSIS

The POD Server acts as a HTTP server returning pod pages from your libery and converts them to the format that you want.
Curently it serports

=over 4

=item *

html

=item *

text

=item *

textc

=item *

xml

=item *

pdf

=item *

raw

=item *

pod

=item *

man

=head1 DESCRIPTION

POD Server requires that you a just the config setings and then it is ready to go.
Just Start it up and then type in the address of the server and pod page in your brouser eg.

F<http://localhost:8181/pod::html>, or
F<http://localhost:8181/IO/Socket::INET?html>.

The format is http://B<Server Address>:B<Server Port>/B<Pod file separated by / or ::>?B<Format>

=head1 AUTHOR

CAJ 020326 The origenal script and pod.

=head1 BUGS

There is know return errors to the client just 200 and a blank file.

=head1 SEE ALSO

I<pod2html(1)>, I<pod2text(1)>, I<pod2pdf(1)>, I<pod2man(1)>, I<pod2xml(1)>

=head1 COPYRIGHT

This program is free software.  You may copy or redistribute it under the same terms as Perl itself.
Future versions may have a different copyright.

=head1 SCRIPT CATEGORIES

Networking

=head1 PREREQUISITES

strict
warnings
IO::Socket::INET
File::Spec
Date::Format

=head1 COREQUISITES

File::FlockDir
Pod::XML
Pod::Pdf
Pod::Text
Pod::Html
Pod::Man

=head1 README

POD Server is a simple http server whitch converts pod to many diferant formats on the fly when they are requested.

=cut