File Coverage

blib/lib/DeltaX/Page.pm

Criterion	Covered	Total	%
statement	151	196	77.0
branch	62	100	62.0
condition	3	9	33.3
subroutine	10	11	90.9
pod	3	3	100.0
total	229	319	71.7

#-----------------------------------------------------------------
package DeltaX::Page;
#-----------------------------------------------------------------
# $Id: Page.pm,v 1.3 2003/09/03 08:15:28 spicak Exp $
#
# (c) DELTA E.S., 2002 - 2003
# This package is free software; you can use it under "Artistic License" from
# Perl.
#
# This package uses some ideas from Perl Embeding Engine
# (from William Tan, you can see it at pee.sourceforge.net)
#-----------------------------------------------------------------

$DeltaX::Page::VERSION = '1.3';

use strict;
use Carp;

#-----------------------------------------------------------------
sub new {
#-----------------------------------------------------------------
# CONSTRUCTOR
#
	my $pkg = shift;
	my $self = {};
	bless ($self, $pkg);

	my $filename = shift;
	croak ("You must supply filename!") unless defined $filename;
	$self->{filename} = $filename;
	$self->{error}		= '';
	$self->{defs}     = [];

	croak ("$pkg created with odd number of parameters".
		" - should be of the form option => value")
		if (@_ % 2);
	for (my $x = 0; $x <= $#_; $x += 2) {
		if ($_[$x] eq '_defs') {
			$self->{defs} = $_[$x+1];
		}
		else {
			$self->{special}{$_[$x]} = $_[$x+1];
		}
	}

	return $self;
}
# END OF new()

#-----------------------------------------------------------------s
sub compile {
#-----------------------------------------------------------------
#
	my $self = shift;
	my $do_prints = shift;
	if (!defined $do_prints) { $do_prints = 1; }

	if ($self->{filename} =~ /^string:/) {
		$self->{buffer} = substr($self->{filename}, 7);
	}
	else {
		# read file
		if (! open (INF, $self->{filename})) {
			$self->{error} = "Cannot open file: $!";
			return 0;
		}

		$self->{buffer} = '';
		while () { $self->{buffer} .= $_; }
		close INF;
	}

	$self->{cursor} = 0;
	$self->{blength} = length($self->{buffer});

	my $token;
	my $type = 0;
	$self->{translated} = '';

	$self->{do_output} = 1;
	$self->{if_level} = 0;
	$self->{if_count} = [];

	while ( ($type = $self->_next_token(\$token)) != -1 ) {
		if ($type == 0) {					# NORMAL BLOCK => print
			if (!$self->{do_output}) { next; }
			if ($token =~ /^[\s\n]*$/gs) { next; }
			$token = _escape($token);
			$self->{translated} .= "print \"$token\";\n" if $do_prints;
		} else {							# CODE
			$token =~ s/<\?(.*)\?>/$1/gs;

			if ($token =~ /^-.*$/s) {		# comment
				next;
			}
			elsif ($token =~ /^=(.*)$/s) {
				if (!$self->{do_output}) { next; }
				$self->{translated} .= "print ($1);\n";
			}
			elsif ($token =~ /^!(.*)$/sm) {
				if (!$self->{do_output}) { next; }
				# special command
				my $tmp = $self->_special($1);
				if (!defined $tmp) { return 0; }
				$self->{translated} .= $tmp;
			}
			elsif ($token =~ /^:(.*)$/s) {
				# command
				if (!$self->_command($1)) { return 0; }
			} else {
				# normal code
				if (!$self->{do_output}) { next; }
				$self->{translated} .= $token;
			}
		}

	}

	$self->{buffer} = '';
	return 1;
}
# END OF compile()

#-----------------------------------------------------------------
sub get_error {
#-----------------------------------------------------------------
#
	my $self = shift;

	return $self->{error};
}
# END OF get_error()

#-----------------------------------------------------------------
sub _next_token {
#-----------------------------------------------------------------
#
	my $self = shift;
	my $token = shift;

	if ($self->{cursor} == ($self->{blength} - 1)) {
		$$token = '';
		return -1;		# no more data
	}

	my $pos = index($self->{buffer}, '{cursor});
	if ($pos == -1) {
		$$token = substr($self->{buffer}, $self->{cursor});
		$self->{cursor} = $self->{blength} - 1;
		return 0;			# normal text
	} elsif ($pos > $self->{cursor}) {
		$$token = substr($self->{buffer}, $self->{cursor}, $pos - $self->{cursor});
		$self->{cursor} = $pos;
		return 0;			# till here normal text
	} else {
		my $end = index ($self->{buffer}, '?>', $pos);
		if ($end == -1) {
			$$token = substr($self->{buffer}, $self->{cursor});
			$self->{cursor} = $self->{blength} - 1;
			return 1;		# code
		}
		$$token = substr($self->{buffer}, $pos, ($end - $pos + 2));
		$self->{cursor} = $end + 2;
		return 1;
	}

}
# END OF _next_token()

#-----------------------------------------------------------------
sub _special {
#-----------------------------------------------------------------
#
	my $self = shift;
	my $token = shift;

	$token =~ s/^\s*//g;

	if ($token =~ /^include/) {
		$token =~ /^include\s+([\S ]+)\s*$/;
		return $self->_include($1, 'include');
	}
	if ($token =~ /^package/) {
		$token =~ /^package\s+([\S ]+)\s*$/;
		return $self->_include($1, 'package');
	}

	$token =~ /^(\S+)\s*(.*)$/s;
	my @args;
	if ($2) { @args = split(/,/, $2); }
	# other special command
	if (! exists $self->{special}{$1} and ! exists $self->{special}{'*'}) {
		if ($#args > -1) { return "$1($2);\n"; }
								else { return "$1();\n"; }
	}
	my $tmp = $1;
	$tmp = '*' if !exists $self->{special}{$tmp};
	unshift @args, $1 if $tmp eq '*';
	return $self->{special}{$tmp}->(@args);

}
# END OF _special

#-----------------------------------------------------------------
sub _include {
#-----------------------------------------------------------------
#
	my $self = shift;
	my $arg  = shift;
	my $type = shift;

	my @defs = @{$self->{defs}};

	my $am_i_string = $self->{filename} =~ /^string:/;

	# relative path!
	if ($arg !~ /^\// || $am_i_string) {
		if ($self->{filename} =~ /^(.*)\/[^\/]*$/ || $am_i_string) {
			if ($self->{special}{$type}) {
				my @tmp;
				($arg, @tmp) = $self->{special}{$type}->($arg);
				push @defs, @tmp;
			} else {
				$arg = "$1/$arg";
			}
		}
	}
	if (!$arg) {
		$self->{error} = "$type: no file found";
		return undef;
	}

	my @spec;
	foreach my $s (sort keys %{$self->{special}}) {
		push @spec, $s, $self->{special}{$s}
	}
	push @spec, '_defs', \@defs;
	my $inc = new DeltaX::Page($arg, @spec);
	if ($inc->compile()) {
		if (!$am_i_string) {
			return "\n#START $type $arg\n".$inc->{translated}."#END $type $arg\n\n\n";
		}
		else {
			return "\n#START $type\n".$inc->{translated}."#END $type\n\n\n";
		}
	} else {
		$self->{error} = "include: unable to compile '$arg': ". $inc->get_error();
		return undef;
	}
}
# END OF _include()

#-----------------------------------------------------------------
sub _escape {
#-----------------------------------------------------------------
#
	my $text = shift;

	$text =~ s/\\/\\\\/g;
	$text =~ s/\n/\\n/g;
	$text =~ s/\t/\\t/g;
	$text =~ s/'/\\'/g;
	$text =~ s/"/\\"/g;
	$text =~ s/\$/\\\$/g;
	$text =~ s/\%/\\\%/g;
	$text =~ s/\@/\\\@/g;
	$text =~ s/&/\\&/g;
	$text =~ s/`/\\`/g;
	$text =~ s/\|/\\\|/g;

	return $text;
}
# END OF escape()

#-----------------------------------------------------------------
sub _command {
#-----------------------------------------------------------------

	my $self = shift;
	my $arg  = shift;

	my $command;
	my @other_args;
	($command, $arg, @other_args) = split(/\s/, $arg);

	if ($command eq 'if') {
		if (!$self->{do_output}) { return 1; }
		$self->{if_level}++;
		$self->{if_count}->[$self->{if_level}]++;
                my $test = $arg;
                if ($arg =~ /^!/) {
                  $test = substr($test, 1);
  		  if (grep (/^$test$/, @{$self->{defs}})) {
		    $self->{do_output} = 0;
		  }
		  else {
		    $self->{do_output} = 1;
  		  }
                }
                else {
  		  if (grep (/^$arg$/, @{$self->{defs}})) {
		    $self->{do_output} = 1;
		  }
		  else {
		    $self->{do_output} = 0;
  		  }
                }
	}
	elsif ($command eq 'else') {
		if (!$self->{if_level}) {
			$self->{error} = "else without if";
			return;
		}
		$self->{do_output} = !$self->{do_output};
	}
	elsif ($command eq 'end') {
		if (!$self->{if_level}) {
			$self->{error} = "end without if";
			return;
		}
		$self->{do_output} = 1;
		$self->{if_count}->[$self->{if_level}]--;
		$self->{if_level}-- if !$self->{if_count}->[$self->{if_level}];
	}
	elsif ($command eq 'for') {
		if (!$self->{do_output}) { return 1; }
		$self->{for_level}++;
		$self->{translated} .= "for $arg ".join(' ', @other_args)." {\n";
	}
	elsif ($command eq 'done') {
		if (!$self->{for_level}) {
			$self->{error} = "done without for";
			return;
		}
		$self->{translated} .= "}\n";
		$self->{for_level}--;
	}
	else {
		$self->{error} = "Uknown conditional '$command' [$arg]";
		return 0;
	}

	return 1;
}
# END OF _command()

#-----------------------------------------------------------------
sub DESTROY {
#-----------------------------------------------------------------
#
	my $self = shift;

}
# END OF DESTROY()

1;

=head1 NAME

DeltaX::Page - Perl module for parsing pages for masser

     _____
    /     \ _____    ______ ______ ___________
   /  \ /  \\__  \  /  ___//  ___// __ \_  __ \
  /    Y    \/ __ \_\___ \ \___ \\  ___/|  | \/
  \____|__  (____  /____  >____  >\___  >__|
          \/     \/     \/     \/     \/        project


=head1 SYNOPSIS

 use DeltaX::Page;

 my $page = new DeltaX::Page('myfile.pg');
 if (!$page->compile()) {
  # write some error
 }
 else {
  my $code = $page->{translated};
 }

=head1 FUNCTIONS

=head2 new()

Constructor. It has one required parameter - name of file to parse. This name
can be prefixed with string: so module it uses as code itself, without reading
the file.

Other parameters are in "directive => sub reference" form (see L<"DIRECTIVES">).

You can define values for conditional output as an array reference to _defs
argument to new() this way:

 my $page = new DeltaX::Page('somepage.pg', dir1=>\&dir,
  _defs=>['defined1', 'defined2']);

=head2 compile()

Tries to compile given file to perl code (which can be evaled). See L<"FILE
SYNTAX"> for more information. Returns true in case of success, otherwise
returns false.

=head2 get_error()

Returns textual representation of error (only valid after compile() call).

=head1 FILE SYNTAX

This module is parsing page code for masser (see masser.sourceforge.net) - it's
something like perl code embeded in HTML (or XML or other) code. It compiles
everything to print statements, except this:

=over

=item *

everything between  is a comment and is ignored

=item *

everything between  is a perl code and is included unchanged

=item *

 is translated to print token; (remember this semicolon!)

=item *

 is used for conditional and looped output; you can use following:

=over

=item if

for example

=item else

for example:


  some output

  some other output


=item end

end of block for if/else

=item for..done

for example:


 ...



 ...


=back

Condition instructions can be embedded.

=item *

 is processed externally (see L<"DIRECTIVES">)

=back

Example:

 Source code:

  Hi, welcome to !

  It's

    my (undef, undef, undef, $day, $mon, $yer) = localtime();
    $mon++; $yer+=1900;
    print sprintf("%02d.%02d.%04d", $day, $mon, $yer);
  ?>

  See you later...

 Compiled code:
  print "Hi, welcome to ";
  print $app_name;
  print "!";
  print "\n\n";
  print "It's\n";
    my (undef, undef, undef, $day, $mon, $yer) = localtime();
    $mon++; $yer+=1900;
    print sprintf("%02d.%02d.%04d", $day, $mon, $yer);
  print "\n\nSee you later\n";

  [code was made a little bit readable :-)]

=head1 DIRECTIVES

Everything in  is a special directive. Module knows
these directives:

=over

=item include

 - includes given file, this means tries to read and compile
this file and (in case of success) includes resulting code into actual code.

=item package

 - works as include

=item everything other

Every other directive must be defined in new() function and apropriate function
will be called (arguments will be given to this function - if there are any).
Everything which is returned by this function is included in the code (function
must return true value - at least one space, if it returns false, it is detected
as an error).

You can define directive in new() for include and package too, but this doesn't
change include or package itself, but module expects that called function
returns real full path to file to be included. Other returned values are got as
additional defines for conditional instructions (see _defs in new()) - but only
for included file.

There is special directive definition *, which means 'everything other', so if
undefined directive is found, function assigned to it will be called.

Example:

 sub my_include {
  my $filename = shift;
  # only relative path
  return substr($filename, rindex($filename,'/')+1);
 }

 sub my_javascript {
  my $javascript_name = shift;
  # code to give someone know that JavaScript code must be generated...
  return "$cgi->add_javascript('$javascript_name');";
 }

 sub my_other {
	my ($directive, @args) = @_;
	# return code according to $directory
 }

 my $page = new DeltaX::Page('test.pg',include=>\&my_include,
  javascript=>\&my_javascript, '*'=>\&my_other);

=back