File Coverage

blib/lib/Encode/Arabic/Parkinson.pm
Criterion Covered Total %
statement 75 75 100.0
branch 32 62 51.6
condition 2 6 33.3
subroutine 16 16 100.0
pod 2 6 33.3
total 127 165 76.9


line stmt bran cond sub pod time code
1             # ###################################################################### Otakar Smrz, 2003/01/23
2             #
3             # Encoding of Arabic: Dil Parkinson's Notation ###################################### 2006/02/03
4              
5             package Encode::Arabic::Parkinson;
6              
7             our $VERSION = '14.1';
8              
9 2     2   13455 use 5.008;
  2         5  
10              
11 2     2   9 use strict;
  2         2  
  2         44  
12 2     2   5 use warnings;
  2         3  
  2         41  
13              
14 2     2   5 use Scalar::Util 'blessed';
  2         3  
  2         113  
15              
16 2     2   380 use Encode::Encoding;
  2         7035  
  2         43  
17 2     2   6 use base 'Encode::Encoding';
  2         4  
  2         695  
18              
19             __PACKAGE__->Define('Parkinson', 'Dil');
20              
21              
22             our $enmode;
23             our $demode;
24              
25             our $optxml;
26              
27             our %modemap = (
28              
29             'default' => 0,
30             'undef' => 0,
31              
32             'fullvocalize' => 0,
33             'full' => 0,
34              
35             'nowasla' => 4,
36              
37             'vocalize' => 3,
38             'nosukuun' => 3,
39              
40             'novocalize' => 2,
41             'novowels' => 2,
42             'none' => 2,
43              
44             'noshadda' => 1,
45             'noneplus' => 1,
46             );
47              
48              
49             # use subs 'encoder', 'decoder'; # ignores later prototypes
50              
51             sub encoder ($); # respect prototypes
52             sub decoder ($); # respect prototypes
53              
54              
55             sub import { # perform import as if Encode were used one level before this module
56              
57 2 50 33 2   14 $optxml = defined $_[1] && $_[1] eq ':xml' ? 1 : 0;
58              
59 2         3 __PACKAGE__->enmode('full');
60 2         7 __PACKAGE__->demode('full');
61              
62 2         3 splice @_, 1, 1;
63              
64 2         8 require Encode;
65              
66 2 100       23 push @Encode::ISA, 'Exporter' unless Encode->can('export_to_level');
67              
68 2         175 Encode->export_to_level(1, @_);
69             }
70              
71              
72             sub encode ($$;$) {
73 2     2 1 1043 my (undef, $text, $check) = @_;
74              
75 2 50       5 $_[1] = '' if $check; # needed by in-place edit
76              
77 2         53 $text = encoder $text;
78              
79 2 50       17 $text = Encode::encode "utf8", $text if Encode::is_utf8($text);
80              
81 2         36 return $text;
82             }
83              
84              
85             sub decode ($$;$) {
86 2     2 1 377 my (undef, $text, $check) = @_;
87              
88 2 50       4 $_[1] = '' if $check; # needed by in-place edit
89              
90 2 50       8 $text = Encode::decode "utf8", $text unless Encode::is_utf8($text);
91              
92 2         81 $text = decoder $text;
93              
94 2         4 return $text;
95             }
96              
97              
98             sub enmode ($$;$$) {
99 2     2 0 4 my ($cls, $mode, $xml, $kshd) = @_;
100              
101 2 50       4 $cls = blessed $cls if ref $cls;
102 2 50       5 $xml = $optxml unless defined $xml;
103              
104 2 50       3 $mode = 'undef' unless defined $mode;
105 2 50       5 $mode = $modemap{$mode} if exists $modemap{$mode};
106              
107 2     2   7 no strict 'refs';
  2         2  
  2         347  
108              
109 2         2 my $return = ${ $cls . '::enmode' };
  2         6  
110              
111 2 50       4 if (defined $mode) {
112              
113 2         2 ${ $cls . '::enmode' } = $mode;
  2         4  
114              
115 2 50       658 my @set = (
    50          
    50          
    50          
    50          
    50          
    50          
116              
117             ( $kshd
118             ? ''
119             : q [\x{0640}] ) .
120             q [\x{0623}\x{0624}\x{0625}] .
121             q [\x{060C}\x{061B}\x{061F}] .
122             q [\x{0621}\x{0622}\x{0626}-\x{063A}\x{0641}-\x{064A}] .
123             q [\x{0660}-\x{0669}] .
124             q [\x{0671}] .
125             q [\x{0651}] .
126             q [\x{064B}-\x{0650}\x{0670}] .
127             q [\x{0652}] .
128             ( $kshd
129             ? q [\x{0640}]
130             : '' )
131              
132             ,
133              
134             ( $kshd
135             ? ''
136             : q [_] ) .
137             q [LWE] .
138             q [,;?] .
139             q [CMYAbQtVjHxdvrzspSDTZcgfqklmnhwey] .
140             q [0-9] .
141             ( $mode == 0
142             ? q [O]
143             : q [A] ) .
144             ( $mode == 1
145             ? ''
146             : q [~] . ( $mode == 2
147             ? ''
148             : q [NUIauiR] . ( $mode == 3
149             ? ''
150             : q [o] ) ) )
151              
152             );
153              
154              
155 2         3 undef &encoder;
156              
157 1     1 0 469 eval q /
  1     2   27  
  1         11  
  2         170  
  2         33  
  2         5  
158              
159             sub encoder ($) {
160              
161             $_[0] =~ tr[/ . $set[0] . q /]
162             [/ . $set[1] . q /]d;
163              
164             return $_[0];
165             }
166             /;
167             }
168              
169 2         4477 return $return;
170             }
171              
172              
173             sub demode ($$;$$) {
174 2     2 0 3 my ($cls, $mode, $xml, $kshd) = @_;
175              
176 2 50       6 $cls = blessed $cls if ref $cls;
177 2 50       6 $xml = $optxml unless defined $xml;
178              
179 2 50       4 $mode = 'undef' unless defined $mode;
180 2 50       9 $mode = $modemap{$mode} if exists $modemap{$mode};
181              
182 2     2   7 no strict 'refs';
  2         2  
  2         329  
183              
184 2         1 my $return = ${ $cls . '::demode' };
  2         5  
185              
186 2 50       6 if (defined $mode) {
187              
188 2         2 ${ $cls . '::demode' } = $mode;
  2         4  
189              
190 2 50       43 my @set = (
    50          
    50          
    50          
    50          
    50          
    50          
191              
192             ( $kshd
193             ? ''
194             : q [_] ) .
195             q [LWE] .
196             q [,;?] .
197             q [CMYAbQtVjHxdvrzspSDTZcgfqklmnhwey] .
198             q [0-9] .
199             q [O] .
200             q [~] .
201             q [NUIauiR] .
202             q [o] .
203             ( $kshd
204             ? q [_]
205             : '' )
206              
207             ,
208              
209             ( $kshd
210             ? ''
211             : q [\x{0640}] ) .
212             q [\x{0623}\x{0624}\x{0625}] .
213             q [\x{060C}\x{061B}\x{061F}] .
214             q [\x{0621}\x{0622}\x{0626}\x{0627}\x{0628}\x{0629}\x{062A}\x{062B}\x{062C}\x{062D}\x{062E}] .
215             q [\x{062F}\x{0630}\x{0631}\x{0632}\x{0633}\x{0634}\x{0635}\x{0636}\x{0637}\x{0638}\x{0639}] .
216             q [\x{063A}\x{0641}\x{0642}\x{0643}\x{0644}\x{0645}\x{0646}\x{0647}\x{0648}\x{0649}\x{064A}] .
217             q [\x{0660}\x{0661}\x{0662}\x{0663}\x{0664}\x{0665}\x{0666}\x{0667}\x{0668}\x{0669}] .
218             ( $mode == 0
219             ? q [\x{0671}]
220             : q [\x{0627}] ) .
221             ( $mode == 1
222             ? ''
223             : q [\x{0651}] . ( $mode == 2
224             ? ''
225             : q [\x{064B}\x{064C}\x{064D}\x{064E}\x{064F}\x{0650}\x{0670}] . ( $mode == 3
226             ? ''
227             : q [\x{0652}] ) ) )
228              
229             );
230              
231              
232 2         4 undef &decoder;
233              
234 2 50 33 2 0 175 eval q /
  2         18  
  2         3  
235              
236             sub decoder ($) {
237              
238             $_[0] =~ tr[/ . $set[0] . q /]
239             [/ . $set[1] . q /]/ . (($kshd or $mode > 0) ? 'd' : '') . q /;
240              
241             return $_[0];
242             }
243             /;
244             }
245              
246 2         1201 return $return;
247             }
248              
249              
250             1;
251              
252             __END__