Attachment #4968 for bug #6458

View | Details | Raw Unified | Return to bug 6458
Collapse All | Expand All




#!/usr/bin/env perl
#simple parser for HTML with Template Toolkit directives. Tokens are put into @tokens and are accesible via next_token and peep_token
package C4::TTParser;
use base qw(HTML::Parser);
use C4::TmplToken;
use strict;
use warnings;


    $self->handler(declaration => "declaration", "self, line, text, is_cdata"); # declaration
    $self->handler(comment => "comment", "self, line, text, is_cdata"); # comments
#    $self->handler(default => "default", "self, line, text, is_cdata"); # anything else
    $self->marked_sections(1); #treat anything inside CDATA tags as text, should really make it a C4::TmplTokenType::CDATA
    $self->unbroken_text(1); #make contiguous whitespace into a single token (can span multiple lines)
    $self->parse_file($filename);
    return $self;

        if( $work =~ m/\[%.*?\]/ ){
            #everything before this tag is text (or possibly CDATA), add a text token to tokens if $`
            if( $` ){
                my $t = C4::TmplToken->new( $`, ($is_cdata? C4::TmplTokenType::CDATA : C4::TmplTokenType::TEXT), $line, $self->{filename} );
                push @tokens, $t;
            }

            #the match itself is a DIRECTIVE $&
            my $t = C4::TmplToken->new( $&, C4::TmplTokenType::DIRECTIVE, $line, $self->{filename} );
            push @tokens, $t;

            # put work still to do back into work
            $work = $' ? $' : 0;
        } else {
            # If there is some left over work, treat it as text token
            my $t = C4::TmplToken->new( $work, ($is_cdata? C4::TmplTokenType::CDATA : C4::TmplTokenType::TEXT), $line, $self->{filename} );
	    
            push @tokens, $t;
            last;

    my $line = shift;
    my $work = shift; #original text
    my $is_cdata = shift;
    my $t = C4::TmplToken->new( $work, ($is_cdata? C4::TmplTokenType::CDATA : C4::TmplTokenType::TEXT), $line, $self->{filename} );
    push @tokens, $t;  
}      


    my $line = shift;
    my $work = shift; #original text
    my $is_cdata = shift;
    my $t = C4::TmplToken->new( $work, ($is_cdata? C4::TmplTokenType::CDATA : C4::TmplTokenType::TEXT), $line, $self->{filename} );
    push @tokens, $t;  
}      


    my $line = shift;
    my $work = shift; #original text
    my $is_cdata = shift;
    my $t = C4::TmplToken->new( $work, ($is_cdata? C4::TmplTokenType::CDATA : C4::TmplTokenType::TEXT), $line, $self->{filename} );
    push @tokens, $t;  
}      


    my $tag = shift;
    my $hash = shift; #hash of attr/value pairs
    my $text = shift; #origional text
    my $t = C4::TmplToken->new( $text, C4::TmplTokenType::TAG, $line, $self->{filename});
    my %attr;
    # tags seem to be uses in an 'interesting' way elsewhere..
    for my $key( %$hash ) {

    my $hash = shift;
    my $text = shift;
    # what format should this be in?
    my $t = C4::TmplToken->new( $text, C4::TmplTokenType::TAG, $line, $self->{filename} );
    my %attr;
    # tags seem to be uses in an 'interesting' way elsewhere..
    for my $key( %$hash ) {




package C4::TmplToken;

use strict;
#use warnings; FIXME - Bug 2505
use C4::TmplTokenType;
require Exporter;

use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);

# FIXME: DIRECTIVE is not necessarily TMPL_VAR !!
sub parameters_and_fields {
    my $this = shift;
    return map { $_->type == C4::TmplTokenType::DIRECTIVE? $_:
		($_->type == C4::TmplTokenType::TAG
			&& $_->string =~ /^<input\b/is)? $_: ()}
	    @{$this->{'_kids'}};
}

# only meaningful for TEXT_PARAMETRIZED tokens
sub anchors {
    my $this = shift;
    return map { $_->type == C4::TmplTokenType::TAG && $_->string =~ /^<a\b/is? $_: ()} @{$this->{'_kids'}};
}

# only meaningful for TEXT_PARAMETRIZED tokens


sub tag_p {
    my $this = shift;
    return $this->type == C4::TmplTokenType::TAG;
}

sub cdata_p {
    my $this = shift;
    return $this->type == C4::TmplTokenType::CDATA;
}

sub text_p {
    my $this = shift;
    return $this->type == C4::TmplTokenType::TEXT;
}

sub text_parametrized_p {
    my $this = shift;
    return $this->type == C4::TmplTokenType::TEXT_PARAMETRIZED;
}

sub directive_p {
    my $this = shift;
    return $this->type == C4::TmplTokenType::DIRECTIVE;
}

###############################################################################

Lines 1-4 Link Here

(-)a/misc/translator/TmplTokenType.pm (-3 / +3 lines)
1	package TmplTokenType;	1	package C4::TmplTokenType;
2		2
3	use strict;	3	use strict;
4	#use warnings; FIXME - Bug 2505	4	#use warnings; FIXME - Bug 2505
Lines 10-16 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); Link Here
10		10
11	=head1 NAME	11	=head1 NAME
12		12
13	TmplTokenType.pm - Types of TmplToken objects	13	C4::TmplTokenType.pm - Types of TmplToken objects
14		14
15	=head1 DESCRIPTION	15	=head1 DESCRIPTION
16		16
Lines 43-49 use vars qw( $_text $_text_parametrized $_cdata Link Here
43		43
44	BEGIN {	44	BEGIN {
45	my $new = sub {	45	my $new = sub {
46	my $this = 'TmplTokenType';#shift;	46	my $this = 'C4::TmplTokenType';#shift;
47	my $class = ref($this) \|\| $this;	47	my $class = ref($this) \|\| $this;
48	my $self = {};	48	my $self = {};
49	bless $self, $class;	49	bless $self, $class;





use strict;
#use warnings; FIXME - Bug 2505
use C4::TmplTokenType;
use C4::TmplToken;
use C4::TTParser;
use VerboseWarnings qw( pedantic_p error_normal warn_normal warn_pedantic );
require Exporter;


    shift;
    my ($filename) = @_;
    #open my $handle,$filename or die "can't open $filename";
    my $parser = C4::TTParser->new;
    $parser->build_tokens( $filename );
    bless {
      filename => $filename,


sub _formalize{
  my $t = shift;
  if( $t->type == C4::TmplTokenType::DIRECTIVE ){
    return '%s';
  } elsif( $t->type == C4::TmplTokenType::TEXT ){
    return _formalize_string_cformat( $t->string );
  } elsif( $t->type == C4::TmplTokenType::TAG ){
    if( $t->string =~ m/^a\b/is ){
      return '<a>';
    } elsif( $t->string =~ m/^input\b/is ){

}

# internal parametization, used within next_token
# method that takes in an array of TEXT and DIRECTIVE tokens (DIRECTIVEs must be GET) and return a C4::TmplTokenType::TEXT_PARAMETRIZED
sub _parametrize_internal{
    my $this = shift;
    my @parts = @_;
    # my $s = "";
    # for my $item (@parts){
    #     if( $item->type == C4::TmplTokenType::TEXT ){
    #         $s .= $item->string;
    #     } else {
    #         #must be a variable directive

    my $s = join( "", map { _formalize $_ } @parts );
    # should both the string and form be $s? maybe only the later? posibly the former....
    # used line number from first token, should suffice
    my $t = C4::TmplToken->new( $s, C4::TmplTokenType::TEXT_PARAMETRIZED, $parts[0]->line_number, $this->filename );
    $t->set_children(@parts);
    $t->set_form($s);
    return $t;

        }
        # if cformat mode is off, dont bother parametrizing, just return them as they come
        return $next unless $self->allow_cformat_p;
        if( $next->type == C4::TmplTokenType::TEXT ){
            push @parts, $next;
        } 
#        elsif( $next->type == C4::TmplTokenType::DIRECTIVE && $next->string =~ m/\[%\s*\w+\s*%\]/ ){
        elsif( $next->type == C4::TmplTokenType::DIRECTIVE ){
            push @parts, $next;
        } 
        elsif ( $next->type == C4::TmplTokenType::CDATA){
            $self->_set_js_mode(1);
            my $s0 = $next->string;
            my @head = ();

		    my $param = $params[$i - 1];
		    warn_normal "$fmt_0: $&: Expected a TMPL_VAR, but found a "
			    . $param->type->to_string . "\n", undef
			    if $param->type != C4::TmplTokenType::DIRECTIVE;
		    warn_normal "$fmt_0: $&: Unsupported "
				. "field width or precision\n", undef
			    if defined $width || defined $prec;

		if (!defined $param) {
		    warn_normal "$fmt_0: $&: Parameter $i not known", undef;
		} else {
		    if ($param->type == C4::TmplTokenType::TAG
			    && $param->string =~ /^<input\b/is) {
			my $type = defined $param->attributes?
				lc($param->attributes->{'type'}->[1]): undef;




    my $s = TmplTokenizer::next_token $h;
    last unless defined $s;
    my($kind, $t, $attr) = ($s->type, $s->string, $s->attributes);
    if ($kind eq C4::TmplTokenType::TEXT) {
        print $output find_translation($t);
    } elsif ($kind eq C4::TmplTokenType::TEXT_PARAMETRIZED) {
        my $fmt = find_translation($s->form);
        print $output TmplTokenizer::parametrize($fmt, 1, $s, sub {
        $_ = $_[0];
        my($kind, $t, $attr) = ($_->type, $_->string, $_->attributes);
        $kind == C4::TmplTokenType::TAG && %$attr?
            text_replace_tag($t, $attr): $t });
    } elsif ($kind eq C4::TmplTokenType::TAG && %$attr) {
        print $output text_replace_tag($t, $attr);
    } elsif ($s->has_js_data) {
        for my $t (@{$s->js_data}) {




    my($x) = @_;
    my $t = $x->type;
    return !$extract_all_p && (
	    $t == C4::TmplTokenType::TEXT? string_negligible_p( $x->string ):
	    $t == C4::TmplTokenType::DIRECTIVE? 1:
	    $t == C4::TmplTokenType::TEXT_PARAMETRIZED
		&& join( '', map { my $t = $_->type;
			$t == C4::TmplTokenType::DIRECTIVE?
				'1': $t == C4::TmplTokenType::TAG?
					'': token_negligible_p( $_ )?
					'': '1' } @{$x->children} ) eq '' );
}

        my $s = TmplTokenizer::next_token $h;
        last unless defined $s;
        my($kind, $t, $attr) = ($s->type, $s->string, $s->attributes);
        if ($kind eq C4::TmplTokenType::TEXT) {
	    if ($t =~ /\S/s && $t !~ /<!/){
		remember( $s, $t );
	    }
        } elsif ($kind eq C4::TmplTokenType::TEXT_PARAMETRIZED) {
	    if ($s->form =~ /\S/s && $s->form !~ /<!/){
		remember( $s, $s->form );
	    }
        } elsif ($kind eq C4::TmplTokenType::TAG && %$attr) {
            # value [tag=input], meta
            my $tag = lc($1) if $t =~ /^<(\S+)/s;
            for my $a ('alt', 'content', 'title', 'value','label') {

EOF
    my $directory_re = quotemeta("$directory/");
    for my $t (string_list) {
	if ($text{$t}->[0]->type == C4::TmplTokenType::TEXT_PARAMETRIZED) {
	    my($token, $n) = ($text{$t}->[0], 0);
	    printf OUTPUT "#. For the first occurrence,\n"
		    if @{$text{$t}} > 1 && $token->parameters_and_fields > 0;
	    for my $param ($token->parameters_and_fields) {
		$n += 1;
		my $type = $param->type;
		my $subtype = ($type == C4::TmplTokenType::TAG
			&& $param->string =~ /^<input\b/is?
				$param->attributes->{'type'}->[1]: undef);
		my $fmt = TmplTokenizer::_formalize( $param );
		$fmt =~ s/^%/%$n\$/;
		if ($type == C4::TmplTokenType::DIRECTIVE) {
#		    $type = "Template::Toolkit Directive";
		    $type = $param->string =~ /\[%(.*?)%\]/is? $1: 'ERROR';
		    my $name = $param->string =~ /\bname=(["']?)([^\s"']+)\1/is?

			    . (defined $value? " value=$value->[1]": '');
		}
	    }
	} elsif ($text{$t}->[0]->type == C4::TmplTokenType::TAG) {
	    my($token) = ($text{$t}->[0]);
	    printf OUTPUT "#. For the first occurrence,\n"
		    if @{$text{$t}} > 1 && $token->parameters_and_fields > 0;

        $pathname =~ s/^.*\/koha-tmpl\/(.*)$/$1/;
	    printf OUTPUT "#: %s:%d\n", $pathname, $token->line_number
		    if defined $pathname && defined $token->line_number;
	    $cformat_p = 1 if $token->type == C4::TmplTokenType::TEXT_PARAMETRIZED;
	}
	printf OUTPUT "#, c-format\n" if $cformat_p;
	printf OUTPUT "msgid %s\n", TmplTokenizer::quote_po

	$msgid =~ s/^SELECTED>//;

	# Create dummy token
	my $token = TmplToken->new( $msgid, C4::TmplTokenType::UNKNOWN, undef, undef );
	remember( $token, $msgid );
	$msgstr =~ s/^(?:LIMIT;|LIMITED;)//g; # unneeded for tmpl_process3
	$translation{$msgid} = $msgstr unless $msgstr eq '*****';




#!/usr/bin/perl

# Copyright (C) 2011 Tamil s.a.r.l.
#
# This file is part of Koha.
#
# Koha is free software; you can redistribute it and/or modify it under the
# terms of the GNU General Public License as published by the Free Software
# Foundation; either version 2 of the License, or (at your option) any later
# version.
#
# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
# A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License along
# with Koha; if not, write to the Free Software Foundation, Inc.,
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.

use warnings;
use strict;
use Test::More tests => 1;
use File::Find;
use Cwd;
use C4::TTParser;


my @files_with_directive_in_tag = do {
    my @files;
    find( sub {
        my $dir = getcwd();
        return if $dir =~ /blib/;
        return unless /\.(tt|inc)$/;
        my $name = $_;
        my $parser = C4::TTParser->new;
        $parser->build_tokens( $name );  
        my @lines;
        while ( my $token = $parser->next_token ) {
            my $attr = $token->{_attr};
            next unless $attr;
            push @lines, $token->{_lc} if $attr->{'[%'};
        }
        ($dir) = $dir =~ /koha-tmpl\/(.*)$/;
        push @files, { name => "$dir/$name", lines => \@lines } if @lines;
      }, ( "./koha-tmpl/opac-tmpl/prog/en",
           "./koha-tmpl/intranet-tmpl/prog/en" )
    );
    @files;
};


ok( !@files_with_directive_in_tag, "TT syntax: not using TT directive within HTML tag" )
    or diag(
          "Files list: \n",
          join( "\n", map { $_->{name} . ': ' . join(', ', @{$_->{lines}})
              } @files_with_directive_in_tag )
       );



=head1 NAME

tt_valid.t

=head1 DESCRIPTION

This test validate Template Toolkit (TT) Koha files.

For the time being an unique validation is done: Test if TT files contain TT
directive within HTML tag. For example:

  <li[% IF

This kind of constuction MUST be avoided because it break Koha translation
process.

=head1 USAGE

From Koha root directory:

prove -v xt/tt_valid.t

=cut


Return to bug 6458

Lines 1-8 Link Here

(-)a/misc/translator/TmplToken.pm (-10 / +10 lines)
1	package TmplToken;	1	package C4::TmplToken;
2		2
3	use strict;	3	use strict;
4	#use warnings; FIXME - Bug 2505	4	#use warnings; FIXME - Bug 2505
5	use TmplTokenType;	5	use C4::TmplTokenType;
6	require Exporter;	6	require Exporter;
7		7
8	use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);	8	use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
Lines 85-92 sub set_children { Link Here
85	# FIXME: DIRECTIVE is not necessarily TMPL_VAR !!	85	# FIXME: DIRECTIVE is not necessarily TMPL_VAR !!
86	sub parameters_and_fields {	86	sub parameters_and_fields {
87	my $this = shift;	87	my $this = shift;
88	return map { $_->type == TmplTokenType::DIRECTIVE? $_:	88	return map { $_->type == C4::TmplTokenType::DIRECTIVE? $_:
89	($_->type == TmplTokenType::TAG	89	($_->type == C4::TmplTokenType::TAG
90	&& $_->string =~ /^<input\b/is)? $_: ()}	90	&& $_->string =~ /^<input\b/is)? $_: ()}
91	@{$this->{'_kids'}};	91	@{$this->{'_kids'}};
92	}	92	}
Lines 94-100 sub parameters_and_fields { Link Here
94	# only meaningful for TEXT_PARAMETRIZED tokens	94	# only meaningful for TEXT_PARAMETRIZED tokens
95	sub anchors {	95	sub anchors {
96	my $this = shift;	96	my $this = shift;
97	return map { $_->type == TmplTokenType::TAG && $_->string =~ /^<a\b/is? $_: ()} @{$this->{'_kids'}};	97	return map { $_->type == C4::TmplTokenType::TAG && $_->string =~ /^<a\b/is? $_: ()} @{$this->{'_kids'}};
98	}	98	}
99		99
100	# only meaningful for TEXT_PARAMETRIZED tokens	100	# only meaningful for TEXT_PARAMETRIZED tokens
Lines 130-156 sub set_js_data { Link Here
130		130
131	sub tag_p {	131	sub tag_p {
132	my $this = shift;	132	my $this = shift;
133	return $this->type == TmplTokenType::TAG;	133	return $this->type == C4::TmplTokenType::TAG;
134	}	134	}
135		135
136	sub cdata_p {	136	sub cdata_p {
137	my $this = shift;	137	my $this = shift;
138	return $this->type == TmplTokenType::CDATA;	138	return $this->type == C4::TmplTokenType::CDATA;
139	}	139	}
140		140
141	sub text_p {	141	sub text_p {
142	my $this = shift;	142	my $this = shift;
143	return $this->type == TmplTokenType::TEXT;	143	return $this->type == C4::TmplTokenType::TEXT;
144	}	144	}
145		145
146	sub text_parametrized_p {	146	sub text_parametrized_p {
147	my $this = shift;	147	my $this = shift;
148	return $this->type == TmplTokenType::TEXT_PARAMETRIZED;	148	return $this->type == C4::TmplTokenType::TEXT_PARAMETRIZED;
149	}	149	}
150		150
151	sub directive_p {	151	sub directive_p {
152	my $this = shift;	152	my $this = shift;
153	return $this->type == TmplTokenType::DIRECTIVE;	153	return $this->type == C4::TmplTokenType::DIRECTIVE;
154	}	154	}
155		155
156	###############################################################################	156	###############################################################################

Lines 2-10 package TmplTokenizer; Link Here

(-)a/misc/translator/TmplTokenizer.pm (-16 / +16 lines)
2		2
3	use strict;	3	use strict;
4	#use warnings; FIXME - Bug 2505	4	#use warnings; FIXME - Bug 2505
5	use TmplTokenType;	5	use C4::TmplTokenType;
6	use TmplToken;	6	use C4::TmplToken;
7	use TTParser;	7	use C4::TTParser;
8	use VerboseWarnings qw( pedantic_p error_normal warn_normal warn_pedantic );	8	use VerboseWarnings qw( pedantic_p error_normal warn_normal warn_pedantic );
9	require Exporter;	9	require Exporter;
10		10
Lines 68-74 sub new { Link Here
68	shift;	68	shift;
69	my ($filename) = @_;	69	my ($filename) = @_;
70	#open my $handle,$filename or die "can't open $filename";	70	#open my $handle,$filename or die "can't open $filename";
71	my $parser = TTParser->new;	71	my $parser = C4::TTParser->new;
72	$parser->build_tokens( $filename );	72	$parser->build_tokens( $filename );
73	bless {	73	bless {
74	filename => $filename,	74	filename => $filename,
Lines 259-269 sub _formalize_string_cformat{ Link Here
259		259
260	sub _formalize{	260	sub _formalize{
261	my $t = shift;	261	my $t = shift;
262	if( $t->type == TmplTokenType::DIRECTIVE ){	262	if( $t->type == C4::TmplTokenType::DIRECTIVE ){
263	return '%s';	263	return '%s';
264	} elsif( $t->type == TmplTokenType::TEXT ){	264	} elsif( $t->type == C4::TmplTokenType::TEXT ){
265	return _formalize_string_cformat( $t->string );	265	return _formalize_string_cformat( $t->string );
266	} elsif( $t->type == TmplTokenType::TAG ){	266	} elsif( $t->type == C4::TmplTokenType::TAG ){
267	if( $t->string =~ m/^a\b/is ){	267	if( $t->string =~ m/^a\b/is ){
268	return '<a>';	268	return '<a>';
269	} elsif( $t->string =~ m/^input\b/is ){	269	} elsif( $t->string =~ m/^input\b/is ){
Lines 281-293 sub _formalize{ Link Here
281	}	281	}
282		282
283	# internal parametization, used within next_token	283	# internal parametization, used within next_token
284	# method that takes in an array of TEXT and DIRECTIVE tokens (DIRECTIVEs must be GET) and return a TmplTokenType::TEXT_PARAMETRIZED	284	# method that takes in an array of TEXT and DIRECTIVE tokens (DIRECTIVEs must be GET) and return a C4::TmplTokenType::TEXT_PARAMETRIZED
285	sub _parametrize_internal{	285	sub _parametrize_internal{
286	my $this = shift;	286	my $this = shift;
287	my @parts = @_;	287	my @parts = @_;
288	# my $s = "";	288	# my $s = "";
289	# for my $item (@parts){	289	# for my $item (@parts){
290	# if( $item->type == TmplTokenType::TEXT ){	290	# if( $item->type == C4::TmplTokenType::TEXT ){
291	# $s .= $item->string;	291	# $s .= $item->string;
292	# } else {	292	# } else {
293	# #must be a variable directive	293	# #must be a variable directive
Lines 297-303 sub _parametrize_internal{ Link Here
297	my $s = join( "", map { _formalize $_ } @parts );	297	my $s = join( "", map { _formalize $_ } @parts );
298	# should both the string and form be $s? maybe only the later? posibly the former....	298	# should both the string and form be $s? maybe only the later? posibly the former....
299	# used line number from first token, should suffice	299	# used line number from first token, should suffice
300	my $t = TmplToken->new( $s, TmplTokenType::TEXT_PARAMETRIZED, $parts[0]->line_number, $this->filename );	300	my $t = C4::TmplToken->new( $s, C4::TmplTokenType::TEXT_PARAMETRIZED, $parts[0]->line_number, $this->filename );
301	$t->set_children(@parts);	301	$t->set_children(@parts);
302	$t->set_form($s);	302	$t->set_form($s);
303	return $t;	303	return $t;
Lines 321-334 sub next_token { Link Here
321	}	321	}
322	# if cformat mode is off, dont bother parametrizing, just return them as they come	322	# if cformat mode is off, dont bother parametrizing, just return them as they come
323	return $next unless $self->allow_cformat_p;	323	return $next unless $self->allow_cformat_p;
324	if( $next->type == TmplTokenType::TEXT ){	324	if( $next->type == C4::TmplTokenType::TEXT ){
325	push @parts, $next;	325	push @parts, $next;
326	}	326	}
327	# elsif( $next->type == TmplTokenType::DIRECTIVE && $next->string =~ m/\[%\s\w+\s%\]/ ){	327	# elsif( $next->type == C4::TmplTokenType::DIRECTIVE && $next->string =~ m/\[%\s\w+\s%\]/ ){
328	elsif( $next->type == TmplTokenType::DIRECTIVE ){	328	elsif( $next->type == C4::TmplTokenType::DIRECTIVE ){
329	push @parts, $next;	329	push @parts, $next;
330	}	330	}
331	elsif ( $next->type == TmplTokenType::CDATA){	331	elsif ( $next->type == C4::TmplTokenType::CDATA){
332	$self->_set_js_mode(1);	332	$self->_set_js_mode(1);
333	my $s0 = $next->string;	333	my $s0 = $next->string;
334	my @head = ();	334	my @head = ();
Lines 383-389 sub parametrize ($$$$) { Link Here
383	my $param = $params[$i - 1];	383	my $param = $params[$i - 1];
384	warn_normal "$fmt_0: $&: Expected a TMPL_VAR, but found a "	384	warn_normal "$fmt_0: $&: Expected a TMPL_VAR, but found a "
385	. $param->type->to_string . "\n", undef	385	. $param->type->to_string . "\n", undef
386	if $param->type != TmplTokenType::DIRECTIVE;	386	if $param->type != C4::TmplTokenType::DIRECTIVE;
387	warn_normal "$fmt_0: $&: Unsupported "	387	warn_normal "$fmt_0: $&: Unsupported "
388	. "field width or precision\n", undef	388	. "field width or precision\n", undef
389	if defined $width \|\| defined $prec;	389	if defined $width \|\| defined $prec;
Lines 400-406 sub parametrize ($$$$) { Link Here
400	if (!defined $param) {	400	if (!defined $param) {
401	warn_normal "$fmt_0: $&: Parameter $i not known", undef;	401	warn_normal "$fmt_0: $&: Parameter $i not known", undef;
402	} else {	402	} else {
403	if ($param->type == TmplTokenType::TAG	403	if ($param->type == C4::TmplTokenType::TAG
404	&& $param->string =~ /^<input\b/is) {	404	&& $param->string =~ /^<input\b/is) {
405	my $type = defined $param->attributes?	405	my $type = defined $param->attributes?
406	lc($param->attributes->{'type'}->[1]): undef;	406	lc($param->attributes->{'type'}->[1]): undef;

Lines 95-110 sub text_replace (**) { Link Here

(-)a/misc/translator/tmpl_process3.pl (-4 / +4 lines)
95	my $s = TmplTokenizer::next_token $h;	95	my $s = TmplTokenizer::next_token $h;
96	last unless defined $s;	96	last unless defined $s;
97	my($kind, $t, $attr) = ($s->type, $s->string, $s->attributes);	97	my($kind, $t, $attr) = ($s->type, $s->string, $s->attributes);
98	if ($kind eq TmplTokenType::TEXT) {	98	if ($kind eq C4::TmplTokenType::TEXT) {
99	print $output find_translation($t);	99	print $output find_translation($t);
100	} elsif ($kind eq TmplTokenType::TEXT_PARAMETRIZED) {	100	} elsif ($kind eq C4::TmplTokenType::TEXT_PARAMETRIZED) {
101	my $fmt = find_translation($s->form);	101	my $fmt = find_translation($s->form);
102	print $output TmplTokenizer::parametrize($fmt, 1, $s, sub {	102	print $output TmplTokenizer::parametrize($fmt, 1, $s, sub {
103	$_ = $_[0];	103	$_ = $_[0];
104	my($kind, $t, $attr) = ($_->type, $_->string, $_->attributes);	104	my($kind, $t, $attr) = ($_->type, $_->string, $_->attributes);
105	$kind == TmplTokenType::TAG && %$attr?	105	$kind == C4::TmplTokenType::TAG && %$attr?
106	text_replace_tag($t, $attr): $t });	106	text_replace_tag($t, $attr): $t });
107	} elsif ($kind eq TmplTokenType::TAG && %$attr) {	107	} elsif ($kind eq C4::TmplTokenType::TAG && %$attr) {
108	print $output text_replace_tag($t, $attr);	108	print $output text_replace_tag($t, $attr);
109	} elsif ($s->has_js_data) {	109	} elsif ($s->has_js_data) {
110	for my $t (@{$s->js_data}) {	110	for my $t (@{$s->js_data}) {

Lines 44-55 sub token_negligible_p( $ ) { Link Here

(-)a/misc/translator/xgettext.pl (-14 / +14 lines)
44	my($x) = @_;	44	my($x) = @_;
45	my $t = $x->type;	45	my $t = $x->type;
46	return !$extract_all_p && (	46	return !$extract_all_p && (
47	$t == TmplTokenType::TEXT? string_negligible_p( $x->string ):	47	$t == C4::TmplTokenType::TEXT? string_negligible_p( $x->string ):
48	$t == TmplTokenType::DIRECTIVE? 1:	48	$t == C4::TmplTokenType::DIRECTIVE? 1:
49	$t == TmplTokenType::TEXT_PARAMETRIZED	49	$t == C4::TmplTokenType::TEXT_PARAMETRIZED
50	&& join( '', map { my $t = $_->type;	50	&& join( '', map { my $t = $_->type;
51	$t == TmplTokenType::DIRECTIVE?	51	$t == C4::TmplTokenType::DIRECTIVE?
52	'1': $t == TmplTokenType::TAG?	52	'1': $t == C4::TmplTokenType::TAG?
53	'': token_negligible_p( $_ )?	53	'': token_negligible_p( $_ )?
54	'': '1' } @{$x->children} ) eq '' );	54	'': '1' } @{$x->children} ) eq '' );
55	}	55	}
Lines 91-105 sub text_extract (*) { Link Here
91	my $s = TmplTokenizer::next_token $h;	91	my $s = TmplTokenizer::next_token $h;
92	last unless defined $s;	92	last unless defined $s;
93	my($kind, $t, $attr) = ($s->type, $s->string, $s->attributes);	93	my($kind, $t, $attr) = ($s->type, $s->string, $s->attributes);
94	if ($kind eq TmplTokenType::TEXT) {	94	if ($kind eq C4::TmplTokenType::TEXT) {
95	if ($t =~ /\S/s && $t !~ /<!/){	95	if ($t =~ /\S/s && $t !~ /<!/){
96	remember( $s, $t );	96	remember( $s, $t );
97	}	97	}
98	} elsif ($kind eq TmplTokenType::TEXT_PARAMETRIZED) {	98	} elsif ($kind eq C4::TmplTokenType::TEXT_PARAMETRIZED) {
99	if ($s->form =~ /\S/s && $s->form !~ /<!/){	99	if ($s->form =~ /\S/s && $s->form !~ /<!/){
100	remember( $s, $s->form );	100	remember( $s, $s->form );
101	}	101	}
102	} elsif ($kind eq TmplTokenType::TAG && %$attr) {	102	} elsif ($kind eq C4::TmplTokenType::TAG && %$attr) {
103	# value [tag=input], meta	103	# value [tag=input], meta
104	my $tag = lc($1) if $t =~ /^<(\S+)/s;	104	my $tag = lc($1) if $t =~ /^<(\S+)/s;
105	for my $a ('alt', 'content', 'title', 'value','label') {	105	for my $a ('alt', 'content', 'title', 'value','label') {
Lines 165-183 msgstr "" Link Here
165	EOF	165	EOF
166	my $directory_re = quotemeta("$directory/");	166	my $directory_re = quotemeta("$directory/");
167	for my $t (string_list) {	167	for my $t (string_list) {
168	if ($text{$t}->[0]->type == TmplTokenType::TEXT_PARAMETRIZED) {	168	if ($text{$t}->[0]->type == C4::TmplTokenType::TEXT_PARAMETRIZED) {
169	my($token, $n) = ($text{$t}->[0], 0);	169	my($token, $n) = ($text{$t}->[0], 0);
170	printf OUTPUT "#. For the first occurrence,\n"	170	printf OUTPUT "#. For the first occurrence,\n"
171	if @{$text{$t}} > 1 && $token->parameters_and_fields > 0;	171	if @{$text{$t}} > 1 && $token->parameters_and_fields > 0;
172	for my $param ($token->parameters_and_fields) {	172	for my $param ($token->parameters_and_fields) {
173	$n += 1;	173	$n += 1;
174	my $type = $param->type;	174	my $type = $param->type;
175	my $subtype = ($type == TmplTokenType::TAG	175	my $subtype = ($type == C4::TmplTokenType::TAG
176	&& $param->string =~ /^<input\b/is?	176	&& $param->string =~ /^<input\b/is?
177	$param->attributes->{'type'}->[1]: undef);	177	$param->attributes->{'type'}->[1]: undef);
178	my $fmt = TmplTokenizer::_formalize( $param );	178	my $fmt = TmplTokenizer::_formalize( $param );
179	$fmt =~ s/^%/%$n\$/;	179	$fmt =~ s/^%/%$n\$/;
180	if ($type == TmplTokenType::DIRECTIVE) {	180	if ($type == C4::TmplTokenType::DIRECTIVE) {
181	# $type = "Template::Toolkit Directive";	181	# $type = "Template::Toolkit Directive";
182	$type = $param->string =~ /\[%(.*?)%\]/is? $1: 'ERROR';	182	$type = $param->string =~ /\[%(.*?)%\]/is? $1: 'ERROR';
183	my $name = $param->string =~ /\bname=(["']?)([^\s"']+)\1/is?	183	my $name = $param->string =~ /\bname=(["']?)([^\s"']+)\1/is?
Lines 193-199 EOF Link Here
193	. (defined $value? " value=$value->[1]": '');	193	. (defined $value? " value=$value->[1]": '');
194	}	194	}
195	}	195	}
196	} elsif ($text{$t}->[0]->type == TmplTokenType::TAG) {	196	} elsif ($text{$t}->[0]->type == C4::TmplTokenType::TAG) {
197	my($token) = ($text{$t}->[0]);	197	my($token) = ($text{$t}->[0]);
198	printf OUTPUT "#. For the first occurrence,\n"	198	printf OUTPUT "#. For the first occurrence,\n"
199	if @{$text{$t}} > 1 && $token->parameters_and_fields > 0;	199	if @{$text{$t}} > 1 && $token->parameters_and_fields > 0;
Lines 220-226 EOF Link Here
220	$pathname =~ s/^.\/koha-tmpl\/(.)$/$1/;	220	$pathname =~ s/^.\/koha-tmpl\/(.)$/$1/;
221	printf OUTPUT "#: %s:%d\n", $pathname, $token->line_number	221	printf OUTPUT "#: %s:%d\n", $pathname, $token->line_number
222	if defined $pathname && defined $token->line_number;	222	if defined $pathname && defined $token->line_number;
223	$cformat_p = 1 if $token->type == TmplTokenType::TEXT_PARAMETRIZED;	223	$cformat_p = 1 if $token->type == C4::TmplTokenType::TEXT_PARAMETRIZED;
224	}	224	}
225	printf OUTPUT "#, c-format\n" if $cformat_p;	225	printf OUTPUT "#, c-format\n" if $cformat_p;
226	printf OUTPUT "msgid %s\n", TmplTokenizer::quote_po	226	printf OUTPUT "msgid %s\n", TmplTokenizer::quote_po
Lines 246-252 sub convert_translation_file () { Link Here
246	$msgid =~ s/^SELECTED>//;	246	$msgid =~ s/^SELECTED>//;
247		247
248	# Create dummy token	248	# Create dummy token
249	my $token = TmplToken->new( $msgid, TmplTokenType::UNKNOWN, undef, undef );	249	my $token = TmplToken->new( $msgid, C4::TmplTokenType::UNKNOWN, undef, undef );
250	remember( $token, $msgid );	250	remember( $token, $msgid );
251	$msgstr =~ s/^(?:LIMIT;\|LIMITED;)//g; # unneeded for tmpl_process3	251	$msgstr =~ s/^(?:LIMIT;\|LIMITED;)//g; # unneeded for tmpl_process3
252	$translation{$msgid} = $msgstr unless $msgstr eq '*****';	252	$translation{$msgid} = $msgstr unless $msgstr eq '*****';

Lines 1-8 Link Here

(-)a/misc/translator/TTParser.pm (-11 / +11 lines)
1	#!/usr/bin/env perl	1	#!/usr/bin/env perl
2	#simple parser for HTML with Template Toolkit directives. Tokens are put into @tokens and are accesible via next_token and peep_token	2	#simple parser for HTML with Template Toolkit directives. Tokens are put into @tokens and are accesible via next_token and peep_token
3	package TTParser;	3	package C4::TTParser;
4	use base qw(HTML::Parser);	4	use base qw(HTML::Parser);
5	use TmplToken;	5	use C4::TmplToken;
6	use strict;	6	use strict;
7	use warnings;	7	use warnings;
8		8
Lines 43-49 sub build_tokens{ Link Here
43	$self->handler(declaration => "declaration", "self, line, text, is_cdata"); # declaration	43	$self->handler(declaration => "declaration", "self, line, text, is_cdata"); # declaration
44	$self->handler(comment => "comment", "self, line, text, is_cdata"); # comments	44	$self->handler(comment => "comment", "self, line, text, is_cdata"); # comments
45	# $self->handler(default => "default", "self, line, text, is_cdata"); # anything else	45	# $self->handler(default => "default", "self, line, text, is_cdata"); # anything else
46	$self->marked_sections(1); #treat anything inside CDATA tags as text, should really make it a TmplTokenType::CDATA	46	$self->marked_sections(1); #treat anything inside CDATA tags as text, should really make it a C4::TmplTokenType::CDATA
47	$self->unbroken_text(1); #make contiguous whitespace into a single token (can span multiple lines)	47	$self->unbroken_text(1); #make contiguous whitespace into a single token (can span multiple lines)
48	$self->parse_file($filename);	48	$self->parse_file($filename);
49	return $self;	49	return $self;
Lines 60-78 sub text{ Link Here
60	if( $work =~ m/\[%.*?\]/ ){	60	if( $work =~ m/\[%.*?\]/ ){
61	#everything before this tag is text (or possibly CDATA), add a text token to tokens if $`	61	#everything before this tag is text (or possibly CDATA), add a text token to tokens if $`
62	if( $` ){	62	if( $` ){
63	my $t = TmplToken->new( $`, ($is_cdata? TmplTokenType::CDATA : TmplTokenType::TEXT), $line, $self->{filename} );	63	my $t = C4::TmplToken->new( $`, ($is_cdata? C4::TmplTokenType::CDATA : C4::TmplTokenType::TEXT), $line, $self->{filename} );
64	push @tokens, $t;	64	push @tokens, $t;
65	}	65	}
66		66
67	#the match itself is a DIRECTIVE $&	67	#the match itself is a DIRECTIVE $&
68	my $t = TmplToken->new( $&, TmplTokenType::DIRECTIVE, $line, $self->{filename} );	68	my $t = C4::TmplToken->new( $&, C4::TmplTokenType::DIRECTIVE, $line, $self->{filename} );
69	push @tokens, $t;	69	push @tokens, $t;
70		70
71	# put work still to do back into work	71	# put work still to do back into work
72	$work = $' ? $' : 0;	72	$work = $' ? $' : 0;
73	} else {	73	} else {
74	# If there is some left over work, treat it as text token	74	# If there is some left over work, treat it as text token
75	my $t = TmplToken->new( $work, ($is_cdata? TmplTokenType::CDATA : TmplTokenType::TEXT), $line, $self->{filename} );	75	my $t = C4::TmplToken->new( $work, ($is_cdata? C4::TmplTokenType::CDATA : C4::TmplTokenType::TEXT), $line, $self->{filename} );
76		76
77	push @tokens, $t;	77	push @tokens, $t;
78	last;	78	last;
Lines 85-91 sub declaration { Link Here
85	my $line = shift;	85	my $line = shift;
86	my $work = shift; #original text	86	my $work = shift; #original text
87	my $is_cdata = shift;	87	my $is_cdata = shift;
88	my $t = TmplToken->new( $work, ($is_cdata? TmplTokenType::CDATA : TmplTokenType::TEXT), $line, $self->{filename} );	88	my $t = C4::TmplToken->new( $work, ($is_cdata? C4::TmplTokenType::CDATA : C4::TmplTokenType::TEXT), $line, $self->{filename} );
89	push @tokens, $t;	89	push @tokens, $t;
90	}	90	}
91		91
Lines 94-100 sub comment { Link Here
94	my $line = shift;	94	my $line = shift;
95	my $work = shift; #original text	95	my $work = shift; #original text
96	my $is_cdata = shift;	96	my $is_cdata = shift;
97	my $t = TmplToken->new( $work, ($is_cdata? TmplTokenType::CDATA : TmplTokenType::TEXT), $line, $self->{filename} );	97	my $t = C4::TmplToken->new( $work, ($is_cdata? C4::TmplTokenType::CDATA : C4::TmplTokenType::TEXT), $line, $self->{filename} );
98	push @tokens, $t;	98	push @tokens, $t;
99	}	99	}
100		100
Lines 103-109 sub default { Link Here
103	my $line = shift;	103	my $line = shift;
104	my $work = shift; #original text	104	my $work = shift; #original text
105	my $is_cdata = shift;	105	my $is_cdata = shift;
106	my $t = TmplToken->new( $work, ($is_cdata? TmplTokenType::CDATA : TmplTokenType::TEXT), $line, $self->{filename} );	106	my $t = C4::TmplToken->new( $work, ($is_cdata? C4::TmplTokenType::CDATA : C4::TmplTokenType::TEXT), $line, $self->{filename} );
107	push @tokens, $t;	107	push @tokens, $t;
108	}	108	}
109		109
Lines 115-121 sub start{ Link Here
115	my $tag = shift;	115	my $tag = shift;
116	my $hash = shift; #hash of attr/value pairs	116	my $hash = shift; #hash of attr/value pairs
117	my $text = shift; #origional text	117	my $text = shift; #origional text
118	my $t = TmplToken->new( $text, TmplTokenType::TAG, $line, $self->{filename});	118	my $t = C4::TmplToken->new( $text, C4::TmplTokenType::TAG, $line, $self->{filename});
119	my %attr;	119	my %attr;
120	# tags seem to be uses in an 'interesting' way elsewhere..	120	# tags seem to be uses in an 'interesting' way elsewhere..
121	for my $key( %$hash ) {	121	for my $key( %$hash ) {
Lines 139-145 sub end{ Link Here
139	my $hash = shift;	139	my $hash = shift;
140	my $text = shift;	140	my $text = shift;
141	# what format should this be in?	141	# what format should this be in?
142	my $t = TmplToken->new( $text, TmplTokenType::TAG, $line, $self->{filename} );	142	my $t = C4::TmplToken->new( $text, C4::TmplTokenType::TAG, $line, $self->{filename} );
143	my %attr;	143	my %attr;
144	# tags seem to be uses in an 'interesting' way elsewhere..	144	# tags seem to be uses in an 'interesting' way elsewhere..
145	for my $key( %$hash ) {	145	for my $key( %$hash ) {

Line 0 Link Here

(-)a/xt/tt_valid.t (-1 / +84 lines)
0	-	1	#!/usr/bin/perl
		2
		3	# Copyright (C) 2011 Tamil s.a.r.l.
		4	#
		5	# This file is part of Koha.
		6	#
		7	# Koha is free software; you can redistribute it and/or modify it under the
		8	# terms of the GNU General Public License as published by the Free Software
		9	# Foundation; either version 2 of the License, or (at your option) any later
		10	# version.
		11	#
		12	# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
		13	# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
		14	# A PARTICULAR PURPOSE. See the GNU General Public License for more details.
		15	#
		16	# You should have received a copy of the GNU General Public License along
		17	# with Koha; if not, write to the Free Software Foundation, Inc.,
		18	# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
		19
		20	use warnings;
		21	use strict;
		22	use Test::More tests => 1;
		23	use File::Find;
		24	use Cwd;
		25	use C4::TTParser;
		26
		27
		28	my @files_with_directive_in_tag = do {
		29	my @files;
		30	find( sub {
		31	my $dir = getcwd();
		32	return if $dir =~ /blib/;
		33	return unless /\.(tt\|inc)$/;
		34	my $name = $_;
		35	my $parser = C4::TTParser->new;
		36	$parser->build_tokens( $name );
		37	my @lines;
		38	while ( my $token = $parser->next_token ) {
		39	my $attr = $token->{_attr};
		40	next unless $attr;
		41	push @lines, $token->{_lc} if $attr->{'[%'};
		42	}
		43	($dir) = $dir =~ /koha-tmpl\/(.*)$/;
		44	push @files, { name => "$dir/$name", lines => \@lines } if @lines;
		45	}, ( "./koha-tmpl/opac-tmpl/prog/en",
		46	"./koha-tmpl/intranet-tmpl/prog/en" )
		47	);
		48	@files;
		49	};
		50
		51
		52	ok( !@files_with_directive_in_tag, "TT syntax: not using TT directive within HTML tag" )
		53	or diag(
		54	"Files list: \n",
		55	join( "\n", map { $_->{name} . ': ' . join(', ', @{$_->{lines}})
		56	} @files_with_directive_in_tag )
		57	);
		58
		59
		60
		61	=head1 NAME
		62
		63	tt_valid.t
		64
		65	=head1 DESCRIPTION
66
67	This test validate Template Toolkit (TT) Koha files.
68
69	For the time being an unique validation is done: Test if TT files contain TT
70	directive within HTML tag. For example:
71
72	<li[% IF
73
74	This kind of constuction MUST be avoided because it break Koha translation
75	process.
76
77	=head1 USAGE
78
79	From Koha root directory:
80
81	prove -v xt/tt_valid.t
82
83	=cut
84