#!/usr/bin/perl -w
use strict;

###############################################################################
##
## Copyright (c) 2006 Jeremy Shute
##
## Permission is hereby granted, free of charge, to any person obtaining a copy
## of this software and associated documentation files (the "Software"), to
## deal in the Software without restriction, including without limitation the
## rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
## sell copies of the Software, and to permit persons to whom the Software is
## furnished to do so, subject to the following conditions:
##
## The above copyright notice and this permission notice shall be included in
## all copies or substantial portions of the Software.
##
## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
## IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
## FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
## AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
## LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
## FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
## IN THE SOFTWARE.
##
###############################################################################

package pcg;

BEGIN {
    use File::Basename;
    push(@INC, dirname($0));
}

my $script_results;
{
  use IO::String;
  my $buffer;
  my $old_fh;
  my $scriptlet_begin;
  sub before_script {
    $buffer = IO::String->new();
    $old_fh = select($buffer);
  }
  sub before_scriptlet {
    my $output = $buffer->string_ref();
    $pcg::scriplet_begin = length($$output);
    print "\n";
  }
  sub after_scriptlet {
    my $output = $buffer->string_ref();
    print "\n" unless (length($$output) > $pcg::scriplet_begin &&
		       $$output =~ /\n$/);
  }
  sub after_script {
    select($old_fh);
    my $output = $buffer->string_ref();
    $pcg::script_results = $$output;
  }
}

sub tokenize {
  my $contents = shift;
  my @tokens = ();
  while ($contents =~ /(<<<pcg)(.*?)(>>>[^\n]*)/s) {
    push(@tokens, ['Literally' => $` . $1 . $2 . $3]);
    push(@tokens, ['Perl' => $2]);
    $contents = $';
    if ($contents =~ /([^\n]*<<<\/pcg>>>)/s) {
      push(@tokens, ['Skip' => ($` =~ y/\n/\n/)]);
      push(@tokens, ['Literally' => $1]);
      $contents = $';
    } else {
      die('<<<pcg>>> unclosed');
    }
  }
  push(@tokens, ['Literally' => $contents]);
  return @tokens;
}

sub chopped_dump {
  my $val = shift;
  use Data::Dumper;
  $Data::Dumper::Terse = 1;
  $Data::Dumper::Useqq = 1;
  $val = Dumper($val);
  chop($val);
  return $val;
}

sub scriptize {
  my @tokens = @_;
  my $script = 'pcg::before_script; $_ = ' .
      chopped_dump(join('', map {
	($_->[0] eq 'Literally' ? $_->[1] :
	 $_->[0] eq 'Skip' ? "\n" : '')
      } @tokens)) . ';';
  my $newlines = 0;
  foreach my $token (@tokens) {
    {
      'Literally' => sub {
	my $literally = shift;
	$newlines += ($literally =~ y/\n/\n/);
	my $tmp = pcg::chopped_dump($literally);
	$script .= "print $tmp;";
      },
      'Perl' => sub {
	my $perl = shift;
	$newlines -= ($perl =~ y/\n/\n/);
	$script .= ("\n" x $newlines) .
	  'pcg::before_scriptlet; ' . $perl . ' pcg::after_scriptlet;';
	$newlines = 0;
      },
      'Skip' => sub {
	$newlines += shift;
      }
    }->{$token->[0]}->($token->[1]);
  }
  $script .= ' pcg::after_script;';
  return $script;
}

sub read_unprocessed {
  my $filename = shift;
  my $file_handle;
  open($file_handle, $filename) || die($!);
  my $contents = join('', <$file_handle>);
  my $script = pcg::scriptize(pcg::tokenize($contents));
  close($file_handle);
  return $script;
}

sub write_processed {
  my $filename = shift;
  my $file_handle;
  open($file_handle, '>' . $filename) || die($!);
  print $file_handle $pcg::script_results;
  close($file_handle);
}

package main;

@ARGV == 1 || die('usage: ' . $0 . ' <filename>
  * Perl code goes between:
    * "<<<pcg>>>", stuff, newline
    * More stuff, which will be overwritten
    * Newline (possibly shared), stuff, "<<</pcg>>>"
  * $_ contains the unprocessed script (unless you overwrite it)
  * Elisp code to process buffers exists in pcg.el
');
print STDERR 'PCG: ' . $ARGV[0] . "\n";
local $_ = pcg::read_unprocessed($ARGV[0]);
eval($_) || die($@);
pcg::write_processed($ARGV[0]);