% Preamble mode stuff here

@* perltangle.

This is a minute variation on tangle which allows it to
construct stuff on the fly for CGI processing.

@p @<Variables@>
@<Input Control@>
@<Output File Control@>
@<Build hash of modules@>
@<Build up output@>
@<Expand macros@>
@<Finishing@>

@* Banner.
This merely provides the introductory banner in true Knuthian style.

@<Banner@>=
print "Content-type: text/plain \n\n\n";

@* Input file control.

First, we look at our filename, check that it's available in some form 
or other and open the file handle. If we don't find it, ask the user.
Then we suck the whole bloody lot into an array.

@<Input Control@>=
chomp($input=$ENV{QUERY_STRING});
if (!open(INPUT, $input) and !open(INPUT, $input.".web" )) {
        print "! I can't find the file $input\n\nPlease try again.\n";
	exit 0;
}
@@source=<INPUT>;


@* Output file control.

Get the file name by lopping off all after the last dot, and adding 'pl'. 
Check that we can write to it and open the file handle.

@<Output File Control@>=

@* Set up flags and variables.

We'll have a flag to let us know what's a module and what's not, and a 
counter for modules (just for the display, really)

@<Variables@>=
@<Banner@>
$program=0;
$count=0;
$hash="#";

@* Begin the first main loop.

The first main processing loop skips through the file looking for modules 
and formatting program output into a module hash.

@<Build hash of modules@>=
foreach (@@source) {
	@<Identify Modules@>
	@<Identify Program@>
}

@* Identify modules.
This determines whether something's documentation:

@<Identify Modules@>=
        if (/@@\ / or /@@\*/) { $program=0; ++$count;}
        if ($program){
	     @<Deal with hashes@>
	     @<Format output@>
	}

@* Deal with hashes.

Making sure that comments are removed if they really {\bf are} comments,
but are properly escaped if they are in quotes is troublesome. For the
moment I'm only dealing with double quotes, because I'm not quite sure
how to deal with the interplay between single and double quotes.

@<Deal with hashes@>=
	$line=$_;
	for ($i = 0; $i < length($line); $i++){
		$_=substr($line,$i,1);
                if (/\"/ and !substr($line,$i-1,1)=~ /\\/) {
                        $dqmode++;
                }
		if (/$hash/ and $dqmode%2==0 and !substr($line,$i-1,1)=~/\\|\$/) {
			$line=substr($line,0,$i);
		}
	}
	$_=$line;

@* Format program output.

Pretty-print what is Perl

@<Format output@>=
                s/@@@@/@@/g;
		s/\n//gm unless /$hash/;
		s/@@\{.*@@\}//gm;
      		$module_code{$current_module}.=$_;

@* Identify program.

We set the program flag to up if we see something that looks like it starts 
with text in angle brackets and an equals sign. If a new piece of 
program has been found, we throw it into the hash, adding a header if necessary.

@<Identify Program@>=
        if (/@@\<.*@@\>=/) {
		chomp($current_module=$_);
		$current_module=~s/(@@\<.*@@\>)=.*/\1/;
		$tidy_name=$current_module;
		$tidy_name=~s/@@\<(.*)@@\>/\1/;
		$program=1; 
		$module_code{$current_module}="\n$hash $count\n" if !$module_code{$current_module};
	}
	
@* More variables.

Here is merely a flag to test if we've found a block of program code, and something to keep the output in, as it were.

@<Variables@>=
$p_found=0;
$output_stack="";

@* Build up output.

OK, this time we wander through, looking for program source, (at-P tags) and
putting everything we find into a big long string.

@<Build up output@>=
foreach (@@source) {
    $p_found=0 if (/@@\<.*@@\>=.*/ or /@@\ / or /@@\*/);
    if (s/\@@\p (.*)/\1/g or $p_found) 
    {
	$p_found=1;
	$output_stack.=$_;
    }
}

@* Expand macros.

We do this by looking for angle bracketed text, replacing it with the 
module or macro which is referenced by the text, until no more macros
remain.

@<Expand macros@>=
while ($output_stack=~/@@\<.*@@\>/)
{
	$looking_for = $output_stack;
	$test=$looking_for;
	$test=~s/(@@\<.*?@@\>)(.*)/\2/;
	$looking_for = $1;
	$replace=$module_code{$looking_for};
	$output_stack=~s/$looking_for/$replace/g;
}
@* Finishing off.

Here we finish off the loop and tidy up the file control.

@<Finishing@>=
print $output_stack;
print "\n";