File Coverage

blib/lib/Locale/XGettext/Util/Keyword.pm
Criterion Covered Total %
statement 56 70 80.0
branch 32 42 76.1
condition 3 5 60.0
subroutine 9 10 90.0
pod 8 8 100.0
total 108 135 80.0


line stmt bran cond sub pod time code
1             #! /bin/false
2              
3             # Copyright (C) 2016-2017 Guido Flohr ,
4             # all rights reserved.
5              
6             # This program is free software; you can redistribute it and/or modify it
7             # under the terms of the GNU Library General Public License as published
8             # by the Free Software Foundation; either version 2, or (at your option)
9             # any later version.
10              
11             # This program is distributed in the hope that it will be useful,
12             # but WITHOUT ANY WARRANTY; without even the implied warranty of
13             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14             # Library General Public License for more details.
15              
16             # You should have received a copy of the GNU Library General Public
17             # License along with this program; if not, write to the Free Software
18             # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
19             # USA.
20              
21             package Locale::XGettext::Util::Keyword;
22             $Locale::XGettext::Util::Keyword::VERSION = '0.6';
23 15     15   119 use strict;
  15         40  
  15         507  
24              
25 15     15   94 use Locale::TextDomain qw(Locale-XGettext);
  15         35  
  15         87  
26              
27             sub new {
28 24     24 1 4878 my ($class, $function, @args) = @_;
29            
30 24         93 my %seen;
31             my $comment;
32 24         0 my $comment_seen;
33 24         0 my $context_seen;
34 24         84 my $self = {
35             function => $function,
36             singular => 0,
37             plural => 0,
38             context => 0,
39             };
40            
41 24         61 foreach my $arg (@args) {
42 45 100       97 $arg = 1 if !defined $arg;
43 45 100       89 $arg = 1 if !length $arg;
44 45 100       204 if ($arg =~ /^([1-9][0-9]*)(c?)$/) {
    50          
45 37         104 my ($pos, $is_ctx) = ($1, $2);
46             die __x("Multiple meanings for argument #{num} for function '{function}'!\n",
47             function => $function, num => $pos)
48 37 100       119 if ($seen{$pos}++);
49 35 100       98 if ($is_ctx) {
    100          
    100          
50 5 100       23 die __x("Multiple context arguments for function '{function}'!\n",
51             function => $function)
52             if $context_seen++;
53 4         12 $self->{context} = $pos;
54             } elsif ($self->{plural}) {
55 1         6 die __x("Too many forms for '{function}'!\n",
56             function => $function);
57             } elsif ($self->{singular}) {
58 8         59 $self->{plural} = $pos;
59             } else {
60 21         49 $self->{singular} = $pos;
61             }
62             } elsif ($arg =~ /^"(.*)"$/) {
63 8 100       24 die __x("Multiple automatic comments for function '{function}'!\n",
64             function => $function)
65             if $comment_seen++;
66 7         21 $self->{comment} = $1;
67             } else {
68 0         0 die __x("Invalid argument specification '{spec}' for function '{function}'!\n",
69             function => $function, spec => $arg);
70             }
71             }
72              
73 19   100     56 $self->{singular} ||= 1;
74              
75 19         88 bless $self, $class;
76             }
77              
78             sub newFromString {
79 11     11 1 481 my ($class, $spec) = @_;
80            
81             # Strip off a possible automatic comment.
82 11         19 my @tokens;
83             my $comment_seen;
84 11         20 my $forms_seen = 0;
85 11         15 my $context_seen;
86 11   33     62 while (@tokens < 4 && length $spec) {
87 24 100       175 if ($spec =~ s/([,:])[\s]*([1-9][0-9]*c?)[\s]*$//) {
    100          
88 18         54 my ($sep, $token) = ($1, $2);
89 18 100       49 if ($token =~ /c$/) {
90 2 50       30 if ($context_seen) {
91 0         0 $spec .= ":$token";
92 0         0 last;
93             }
94 2         4 $context_seen = 1;
95             } else {
96 16 50       35 if ($forms_seen >= 2) {
97 0         0 $spec .= ":$token";
98 0         0 last;
99             }
100 16         27 ++$forms_seen;
101             }
102 18         36 unshift @tokens, $token;
103              
104 18 100       60 last if ':' eq $sep;
105             } elsif ($spec =~ s/([,:])[\s]*"(.*)"[\s]*$//) {
106 4         15 my ($sep, $token) = ($1, $2);
107 4 50       16 if ($comment_seen) {
108 0         0 $spec .= qq{:"$token"};
109 0         0 last;
110             }
111              
112 4         13 my $comment = $token;
113             # This is what GNU xgettxt does.
114 4         10 $comment =~ s/"//;
115 4         12 unshift @tokens, qq{"$token"};
116            
117 4 50       20 last if ':' eq $sep;
118             } else {
119 2         5 last;
120             }
121             }
122 11         41 my $function = $spec;
123 11 50       30 $function = shift @tokens if !length $spec;
124              
125 11         33 return $class->new($function, @tokens);
126             }
127              
128             sub function {
129 11     11 1 1223 shift->{function};
130             }
131              
132             sub singular {
133 11     11 1 38 shift->{singular};
134             }
135              
136             sub plural {
137             shift->{plural}
138 11     11 1 46 }
139              
140             sub context {
141 4     4 1 19 shift->{context};
142             }
143              
144             sub comment {
145 11     11 1 38 shift->{comment};
146             }
147              
148             sub dump {
149 0     0 1   my ($self) = @_;
150              
151 0           my $dump = $self->function . ':';
152 0 0         $dump .= $self->context . 'c,' if $self->context;
153 0           $dump .= $self->singular . ',';
154 0 0         $dump .= $self->plural . '.' if $self->plural;
155 0           chop $dump;
156              
157 0           return $dump;
158             }
159              
160             1;