[Templates-cvs] cvs commit: TT3/lib/Template/Generator Debug.pm

[cvs@template-toolkit.org]

cvs         04/11/15 19:38:38

  Added:       lib/Template/Generator Debug.pm
  Log:
  * moved the debugging generator from Template::TT3
  
  Revision  Changes    Path
  1.1                  TT3/lib/Template/Generator/Debug.pm
  
  Index: Debug.pm
  ===================================================================
  #========================================================================
  #
  # Template::Generator::Debug
  #
  # DESCRIPTION
  #   Back-end code generator which creates a text representation of the 
  #   parsed nodes for debugging purposes.
  # 
  # AUTHOR
  #   Andy Wardley <abw@wardley.org>
  #
  # COPYRIGHT
  #   Copyright (C) 1996-2003 Andy Wardley.  All Rights Reserved.
  #   Copyright (C) 1998-2002 Canon Research Centre Europe Ltd.
  #
  #   This module is free software; you can redistribute it and/or
  #   modify it under the same terms as Perl itself.
  #
  # REVISION
  #   $Id: Debug.pm,v 1.1 2004/11/15 19:38:38 abw Exp $
  #
  #========================================================================
  
  package Template::Generator::Debug;
  
  use strict;
  use warnings;
  use Template::Generator;
  use base qw( Template::Generator );
  
  our $VERSION = sprintf("%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/);
  our $DEBUG   = 0 unless defined $DEBUG;
  our $ERROR   = '';
  our $DEFAULT = '_default';
  
  
  sub integer {
      my ($self, $value) = @_;
      return "<integer:$value>";
  }
  
  sub number {
      my ($self, $value) = @_;
      return "<number:$value>";
  }
  
  
  sub ident {
      my ($self, $name, $args) = @_;
      return "<ident:$name>" 
  }
  
  
  sub value {
      my ($self, $value) = @_;
      return $self->generate($value);
  }
  
  
  sub squote {
      my ($self, $value) = @_;
      return "<squote:$value>";
  }
  
  
  sub dquote {
      my ($self, $list) = @_;
      my $items = '';
          my $out;
  
      foreach my $item (@$list) {
          if (ref $item) {
              $out = $self->generate($item) || return;
              $out =~ s/\n/\n  /g;
          }
          else {
              $out = "<text:$item>";
          }
          $items .= "  $out\n";
      }
  
      return "<dquote:\n$items>";
  }
  
  
  sub list {
      my ($self, $list) = @_;
      my $items = '';
      my $out;
  
      foreach my $item (@$list) {
          $out = $self->generate($item) || return;
          $out =~ s/\n/\n  /g;
          $items .= "  $out\n";
      }
      return "<list:\n$items>";
  }
  
  
  sub qwlist {
      my ($self, $left, $list, $right) = @_;
      for ($list) {
          s/^\s+//;
          s/\s+$//;
      }
      return "<qwlist($left, $right):$list>";
  }
  
  
  sub hash {
      my ($self, $list) = @_;
      my $items = '';
  
      # copy list because we're getting destructive
      my @list = @$list;
  
      while (@list) {
          my ($key, $value) = splice(@list, 0, 2);
          $value = $self->generate($value) || return;
          $value =~ s/\n/\n    /g;
          $items .= "  <key:$key>\n  <value:\n    $value\n  >\n";
      }
      return "<hash:\n$items>";
  }
  
  
  sub data {
      my ($self, $item) = @_;
      $item = $self->generate($item) || return;
      $item =~ s/\n/\n  /g;
      return "<data:\n  $item\n>";
  }
  
  
  sub named {
      my ($self, $name, $value) = @_;
      $value = $self->generate($value) || return;
      $value =~ s/\n/\n    /g;
      return "<named:\n  <name:$name>\n  <value:\n    $value\n  >\n>";
  }
  
  
  sub variable {
      my ($self, $nodes) = @_;
      my ($nodeout, $argout);
      my $out = '';
  
      foreach my $node (@$nodes) {
          my ($name, $item, $args) = @$node;
  
          $nodeout =  $self->generate($node) || return;
          $nodeout =~ s/\n/\n    /g;
  
          if ($args) {
              my $argtext = '';
              foreach my $arg (@$args) {
                  $argout = $self->generate($arg) || return;
                  $argout =~ s/\n/\n      /g;
                  $argtext .= "      $argout\n";
              };
              $args = "    <args:\n$argtext    >\n";
          }
          else {
              $args = '';
          }
  
          $out .= "  <node:\n    $nodeout\n$args  >\n";
      }
  
      return "<variable:\n$out>";
  
  }
  
  
  sub binops {
      my ($self, $list, @others) = @_;
  #    local $" = ', ';
  #    print "BINOPS: [$list] [@others]\n";
      my $items = '';
      my $out;
  
      foreach my $item (@$list) {
          $out = ref $item ? $self->generate($item) || return : "<op:$item>";
          $out =~ s/\n/\n  /g;
          $items .= "  $out\n";
      }
      return "<binops:\n$items>";
  }
  
  sub unaryop {
      my ($self, $op, $term) = @_;
      $term = $self->generate($term) || return;
      $term =~ s/\n/\n    /g;
      return "<unaryop:\n  <op:$op>\n  <term:\n    $term\n  >\n>";
  }
  
  sub tertiary {
      my ($self, $expr, $true, $false) = @_;
  
      $expr  = $self->generate($expr)  || return;
      $true  = $self->generate($true)  || return;
      $false = $self->generate($false) || return;
      foreach ($expr, $true, $false) {
          s/\n/\n    /g;
      }
      return "<tertiary:\n  <expression:\n    $expr\n  >\n  <true:\n    $true\n  >\n  <false:\n    $false\n  >\n>";
  }
  
  sub range {
      my ($self, $from, $to) = @_;
  
      $from  = $self->generate($from) || return;
      $to    = $self->generate($to)   || return;
      foreach ($from, $to) {
          s/\n/\n    /g;
      }
      return "<range:\n  <from:\n    $from\n  >\n  <to:\n    $to\n  >\n>";
  }
  
  
  sub parens {
      my ($self, $term) = @_;
  
      $term = $self->generate($term) || return;
      $term =~ s/\n/\n  /g;
      return "<parens:\n  $term\n>";
  }
  
  sub directive {
      my ($self, $dir) = @_;
      return "<directive:$dir>";
  }
  
  sub filename {
      my ($self, $file) = @_;
      return "<filename:$file>";
  }
  
  sub args {
      my ($self, $args) = @_;
  
      if ($args && @$args) {
          my $argtext = '';
          foreach my $arg (@$args) {
              my $text = $self->generate($arg) || return;
              $text =~ s/\n/\n  /g;
              $argtext .= "  $text\n";
          }
          $args = $argtext;
      }
      else {
          $args = "";
      }
  
      return $args;
  }
  
  
  sub include {
      my ($self, $file, $args) = @_;
      $file = $self->generate($file) || return;
      $file =~ s/\n/\n  /g;
      $args = $self->args($args);
      return "<include:\n  $file\n$args>";
  }
  
  sub process {
      my ($self, $file, $args) = @_;
      $file = $self->generate($file) || return;
      $file =~ s/\n/\n  /g;
      $args = $self->args($args);
      return "<process:\n  $file\n$args>";
  }
  
  sub wrapper {
      my ($self, $file, $args, $content) = @_;
      $file = $self->generate($file) || return;
      $file =~ s/\n/\n  /g;
      $args = $self->args($args);
      $content = $self->generate($content);
      $content =~ s/\n/\n  /g;
      return "<wrapper:\n  $file\n  $args  $content\n>";
  }
  
  sub text {
      my ($self, $text) = @_;
      my $textref = ref $text ? $text : \$text;
      $$textref =~ s/\n/\\n/g;
      return "<text:$$textref>";
  }
  
  sub get {
      my ($self, $item) = @_;
      $item = $self->generate($item) || return;
      $item =~ s/\n/\n  /g;
      return "<get:\n  $item\n>";
  }
  
  sub for {
      my ($self, $var, $item) = @_;
      $var  = $self->generate($var) || return;
      $var  =~ s/\n/\n  /g;
      $item = $self->generate($item) || return;
      $item =~ s/\n/\n  /g;
      return "<for:\n  <data:$var>\n  $item\n>";
  }
  
  sub if {
      my ($self, $expr, $block, @rest) = @_;
      $expr = $self->generate($expr) || return;
      $expr =~ s/\n/\n    /g;
      $expr = "<expr:\n    $expr\n  >";
      $block = $self->generate($block) || return;
      $block =~ s/\n/\n  /g;
      $self->debug("if rest: [@rest]\n") if $DEBUG;
      my $rest = '';
      if (@rest) {
          foreach my $r (@rest) {
              $self->debug(" - [@$r]\n") if $DEBUG;
              my $out = $self->generate($r) || return;
              $out =~ s/\n/\n  /g;
              $rest .= "  $out\n";
          }
  #        $rest = "  $rest\n";
      }
              
      return "<if\n  $expr\n  $block\n$rest>";
  }
  
  
  sub elsif {
      my ($self, $expr, $block) = @_;
      $expr = $self->generate($expr) || return;
      $expr =~ s/\n/\n    /g;
      $expr = "<expr:\n    $expr\n  >";
      $block = $self->generate($block) || return;
      $block =~ s/\n/\n  /g;
      return "<elsif\n  $expr\n  $block\n>";
  }
  
  sub else {
      my ($self, $block) = @_;
      $block = $self->generate($block) || return;
      $block =~ s/\n/\n  /g;
      return "<else:\n  $block\n>";
  }
  
  
  
  sub set {
      my ($self, $list) = @_;
      my $items = '';
      my $out;
  
      foreach my $item (@$list) {
          $out = $self->generate($item) || return;
          $out =~ s/\n/\n  /g;
          $items .= "  $out\n";
      }
      return "<set:\n$items>";
  }
  
  sub assign {
      my ($self, $var, $val) = @_;
      $var = $self->generate($var) || return;
      $val = $self->generate($val) || return;
      $var =~ s/\n/\n  /g;
      $val =~ s/\n/\n  /g;
      return "<assign:\n  $var\n  $val\n>";
  }
  
  sub gen_debug {
      my ($self, $info) = @_;
      $info->{ src } =~ s/\n/\\n/g;
      $info->{ src } =~ s/\s+/ /g;
      return "<debug:$info->{ type } at line $info->{ line }: $info->{ src }>";
  }
  
  sub comment {
      my ($self, $comment) = @_;
      return "<comment:$comment>";
  }
  
  sub block {
      my ($self, $list) = @_;
      my $items = '';
      my $out;
  
      foreach my $item (@$list) {
          $out = $self->generate($item) || return;
          $out =~ s/\n/\n  /g;
          $items .= "  $out\n";
      }
      return "<block:\n$items>";
  }
  
  sub end {
      my ($self, $list) = @_;
      my $items = '';
      my $out;
  
      foreach my $item (@$list) {
          $out = $self->generate($item) || return;
          $out =~ s/\n/\n  /g;
          $items .= "  $out\n";
      }
      return "<end>";
  }
  
  
  
  sub template {
      my ($self, $body) = @_;
      my $items = '';
      my $out;
  
      foreach my $item (@$body) {
          $out = $self->generate($item) || return;
          $out =~ s/\n/\n  /g;
          $items .= "  $out\n";
      }
      return "<template:\n$items>";
  
  #    $block = $self->generate($block) || return;
  #    $block =~ s/\n/\n  /g;
  #    return "<template:\n  $block\n>";
  }
  
  sub test {
      my ($self, $item) = @_;
      return "<test:$item>";
  }
  
  
  # NOTE: this is temporary
  
  sub _default {
      my ($self, $name, @items) = @_;
      my ($out, $items);
  
      foreach my $item (@items) {
          $out = $self->generate($item) || return;
          $out =~ s/\n/\n  /g;
          $items .= "  $out\n";
      }
      return "<$name:\n$items>";
  }
      
  1;
  __END__
  
  =head1 NAME
  
  Template::TT3::Generator::Debug - debugging code generator
  
  =head1 SYNOPSIS
  
      Template::TT3::Generator::Debug;
  
      # TODO
  
  =head1 DESCRIPTION
  
  # TODO
  
  =head1 METHODS
  
  =head2 new()
  
  # TODO
  
  =head2 generate($item)
  
  TODO
  
  =head1 AUTHOR
  
  Andy Wardley  E<lt>abw@wardley.orgE<gt>
  
  =head1 VERSION
  
  $Revision: 1.1 $
  
  =head1 COPYRIGHT
  
    Copyright (C) 1996-2003 Andy Wardley.  All Rights Reserved.
    Copyright (C) 1998-2002 Canon Research Centre Europe Ltd.
  
  This module is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
  
  =cut
  
  # Local Variables:
  # mode: perl
  # perl-indent-level: 4
  # indent-tabs-mode: nil
  # End:
  #
  # vim: expandtab shiftwidth=4: