File Coverage

blib/lib/CzFast.pm
Criterion Covered Total %
statement 66 92 71.7
branch 10 40 25.0
condition 0 9 0.0
subroutine 11 12 91.6
pod 0 5 0.0
total 87 158 55.0


line stmt bran cond sub pod time code
1              
2             # $Id: CzFast.pm,v 1.7 2001/03/21 15:30:32 trip Exp $
3              
4             =head1 NAME
5              
6             B
7              
8              
9             =head1 SYNOPSIS
10              
11             Further documentation of this module is available only in czech language.
12              
13             use CzFast qw( &czrecode &czregexp &detect_client_charset );
14            
15             my $str = 'Drogy ne !';
16              
17             # Prekodovani retezce z jednoho kodovani do druheho:
18             my $recoded_str = &czrecode('windows-1250', 'iso-8859-2', $str);
19              
20             # Ziskani regulerniho vyrazu pro porovnavani bez ohledu
21             # na diakritiku a velka/mala pismena:
22             my $diacritics_unsensitive_regexp = &czregexp($str);
23            
24             # Detekce kodovani WWW klienta:
25             my $charset = &detect_client_charset();
26              
27              
28             =head1 DESCRIPTION
29              
30             Modul rozeznava tyto identifikatory znakovych sad a jejich varianty:
31              
32             us-ascii nebo ascii
33             iso-8859-1
34             iso-8859-2 nebo unix
35             windows-1250 nebo windows
36             kam nebo kamenicti
37             pclatin2
38             koi8cs
39             apple-ce nebo mac nebo macintosh
40             cp850
41              
42             V identifikatorech se B.
43              
44             Funkce B je velmi uzitecna zejmena pro vyhledavani v databazich,
45             podporujicich regulerni vyrazy. Implementace pocita s sesti kombinacemi
46             pro pismena E a U - varianty s carkou i hackem, resp. carkou i krouzkem.
47             Vstupem teto funkce B.
48              
49             Funkce provadi eskejpovani znaku, ktere maji v tride charakteru regulernich
50             vyrazu specialni vyznam - '^', '-' a ']'. Toto eskejpovani je mozne provest
51             dvema zpusoby, standardnim POSIX pouzivanym napr. programem grep, nebo
52             zpusobem nutnym v Perlove implementaci. V pripade Perlu je eskejpovani
53             provadeno jinak a s ohledem na dalsi skupiny znaku se specialnim vyznamem,
54             jako je napr. '\w' nebo znak '\'. Funkce implicitne eskejpuje pro Perl,
55             eskejpovani POSIX lze aktivovat pomoci volitelneho druheho parametru.
56             Pokud je tento druhy parametr true - napr. retezec 'posix' nebo hodnota '1',
57             eskejpuje funkce dle POSIXU.
58              
59             Pro pouziti v SQL je nutne zvolit spravny format eskejpovani podle toho,
60             ktery pouziva vase databaze. Napr. databaze MySQL pouziva eskejpovani
61             POSIX, a je pak tedy nutne tuto funkci volat jako &czregexp($str, 1).
62              
63              
64             Prvnim parametrem funkce B je vstupni kodovani, druhym vystupni
65             kodovani a tretim retezec, ktery ma byt prekodovan. Vstupni retezec neni
66             modifikovan, funkce vraci prekodovany vstup jako svou navratovou hodnotu.
67              
68              
69             Funkce B vyuziva promenne prostredi, nastavovane
70             webserverem pro spoustene CGI programy na zaklade HTTP hlavicek zaslanych
71             klientem, pro urceni jake kodovani cestiny tento klient pouziva.
72             Vraci kodovani klienta ve forme identifikatoru popsanych vyse, v jejich
73             zakladni variante (ie. jako napr. 'windows-1250').
74              
75             Jadro modulu je z duvodu vyssi rychlosti napsano v jazyce C, jako dynamicky
76             zavadeny objekt interpretu Perlu. Pro systemy nepodporujici dynamicke
77             zavadeni za behu, je mozne modul staticky slinkovat s interpretem pri
78             jeho kompilaci. Toto je blize popsano v dokumentaci Perlu. Modul je takto
79             vyrazne rychlejsi nez jine dostupne Perl moduly pro prekodovani. Modul
80             vyuziva konverzni mapy vytvorene Jaromirem Doleckem pro projekt csacek
81             (http://www.csacek.cz) a je csackem inspirovan i v reseni detekce kodovani
82             klienta.
83              
84              
85             =head1 AUTHOR
86              
87             B, tripiecz@yahoo.com
88              
89             Prague, the Czech republic
90              
91             This program uses character tables created by Jaromir Dolecek for
92             the Csacek project (http://www.csacek.cz).
93              
94              
95             =head1 LICENSE
96              
97             CzFast - Perl module for czech charsets manipulation
98              
99             Copyright (C) 2000 Tomas Styblo (tripiecz@yahoo.com)
100              
101             This program uses character tables created by Jaromir Dolecek for
102             the Csacek project (http://www.csacek.cz).
103              
104             This module is free software; you can redistribute it and/or modify it
105             under the terms of either:
106              
107             a) the GNU General Public License as published by the Free Software
108             Foundation; either version 1, or (at your option) any later version,
109             or
110              
111             b) the "Artistic License" which comes with this module.
112              
113             This program is distributed in the hope that it will be useful,
114             but WITHOUT ANY WARRANTY; without even the implied warranty of
115             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either
116             the GNU General Public License or the Artistic License for more details.
117              
118             You should have received a copy of the Artistic License with this
119             module, in the file ARTISTIC. If not, I'll be glad to provide one.
120              
121             You should have received a copy of the GNU General Public License
122             along with this program; if not, write to the Free Software
123             Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
124             USA
125              
126              
127             =head1 SEE ALSO
128              
129             perl(1).
130              
131             =cut
132              
133              
134             package CzFast; # CzFast.xs
135              
136 1     1   1330 use strict;
  1         2  
  1         55  
137 1     1   1325 use integer;
  1         15  
  1         8  
138             # use warnings; # uncomment if you have a recent Perl version
139 1     1   43 use Carp;
  1         4  
  1         146  
140              
141 1     1   7 use Exporter;
  1         3  
  1         41  
142 1     1   7 use DynaLoader;
  1         3  
  1         48  
143              
144             BEGIN {
145 1     1   7 use vars qw( $VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS );
  1         2  
  1         450  
146 1     1   34 @ISA = qw( Exporter DynaLoader );
147 1         4 %EXPORT_TAGS = ();
148 1         4 @EXPORT_OK = qw( &czrecode &czregexp &detect_client_charset );
149 1         3 @EXPORT = ();
150 1         1854 $VERSION = '0.10';
151             }
152              
153             # functions
154             sub czrecode;
155             sub czregexp;
156             sub czvardiac;
157             sub detect_client_charset;
158             sub lookup_charset;
159              
160             # XS:
161             sub _czgetmap;
162             sub _czrecode;
163              
164              
165             sub czrecode {
166 2     2 0 226 return &_czrecode (&lookup_charset($_[0]), &lookup_charset($_[1]), $_[2]);
167             }
168              
169              
170             sub czregexp {
171 1     1 0 42 my $input = $_[0];
172 1         2 my $posix_escaping = $_[1];
173 1         42 my $ascii = &_czrecode (&lookup_charset('iso-8859-2'),
174             &lookup_charset('us-ascii'), $input);
175 1         3 my $no_diac_lc = lc($ascii);
176 1         3 my $no_diac_uc = uc($ascii);
177 1         4 my $var_no_diac_lc = &czvardiac($no_diac_lc);
178 1         4 my $var_no_diac_uc = &czvardiac($no_diac_uc);
179 1         5 my @no_diac_lc = split(//, $no_diac_lc);
180 1         5 my @no_diac_uc = split(//, $no_diac_uc);
181 1         5 my @var_no_diac_lc = split(/\x0/, $var_no_diac_lc);
182 1         6 my @var_no_diac_uc = split(/\x0/, $var_no_diac_uc);
183 1         2 my $ret;
184              
185 1         5 for(my $i = 0; $i < @no_diac_lc; $i++) {
186 13         10 $ret .= '[';
187 13         17 $_ = $no_diac_lc[$i];
188 13         13 $_ .= $no_diac_uc[$i];
189 13         11 $_ .= $var_no_diac_lc[$i];
190 13         37 $_ .= $var_no_diac_uc[$i];
191              
192 13 50       20 if ($posix_escaping) {
193             # posix eskejpovani
194             # od kazdeho eskejpovaneho specialniho znaku staci mit ve
195             # vyslednem retezci pouze jednu kopii
196 0         0 s/^\^(.*)$/$1^/; # premistit '^' na prvni pozici nakonec
197 0 0       0 $_ .= '-' if (tr/-//d); # premistit '-' nakonec
198 0 0       0 $_ = ']'.$_ if (tr/]//d); # premistit '-' na prvni pozici
199             }
200             else {
201             # perl eskejpovani (implicitni)
202 13         20 s/\\/\\\\/g;
203 13         15 s/\^/\\^/g;
204 13         12 s/\]/\\]/g;
205 13         13 s/\[/\\[/g;
206 13         14 s/\-/\\-/g;
207             }
208            
209 13         14 $ret .= $_;
210 13         26 $ret .= ']';
211             }
212              
213 1         39 return $ret;
214             }
215              
216              
217             sub czvardiac {
218 2     2 0 13 my @str = split(//, $_[0]);
219 2         3 my $ret;
220            
221 2         5 foreach my $char (@str) {
222 26 100       67 if ($char eq "\x75") { $ret .= "\xFA\xF9\x0" } # male U
  1 100       2  
    100          
    100          
223 1         2 elsif ($char eq "\x55") { $ret .= "\xDA\xD9\x0" } # velke U
224 1         3 elsif ($char eq "\x65") { $ret .= "\xE9\xEC\x0" } # male E
225 1         2 elsif ($char eq "\x45") { $ret .= "\xC9\xCC\x0" } # velke E
226             else {
227 22         23 $char =~ tr/\x41\x43\x44\x49\x4E\x4F\x52\x53\x54\x59\x5A\x61\x63\x64\x69\x6E\x6F\x72\x73\x74\x79\x7A/\xC1\xC8\xCF\xCD\xD2\xD3\xD8\xA9\xAB\xDD\xAE\xE1\xE8\xEF\xED\xF2\xF3\xF8\xB9\xBB\xFD\xBE/;
228 22         34 $ret .= $char."\x0";
229             }
230             }
231 2         7 return $ret;
232             }
233              
234              
235             sub detect_client_charset {
236 0     0 0 0 my ($ch, $ua, $lang);
237 0 0       0 if (@_) {
238 0         0 ($ch, $ua, $lang) = @_;
239             }
240             else {
241 0         0 $ch = $ENV{'HTTP_ACCEPT_CHARSET'};
242 0         0 $ua = $ENV{'HTTP_USER_AGENT'};
243 0         0 $lang = $ENV{'HTTP_ACCEPT_LANGUAGE'};
244             }
245            
246             # ch = Accept-Charset
247             # ua = User-Agent
248             # lang = Accept-Language
249            
250 0 0 0     0 if ($ch and ($ua !~ /Mozilla\/4/i or $ua !~ /mac/i)) {
    0 0        
    0          
251 0 0 0     0 if ($ch =~ /windows-1250/i) {
    0          
    0          
    0          
252 0         0 return "windows-1250";
253             }
254             elsif ($ch =~ /iso-8859-2/i) {
255 0         0 return "iso-8859-2";
256             }
257             elsif ($ch =~ /apple-ce/i or $ch =~ /mac-ce/i) {
258 0         0 return "apple-ce";
259             }
260             elsif ($ch =~ /\*/) {
261 0         0 return "iso-8859-2";
262             }
263             else {
264 0         0 return "us-ascii";
265             }
266             }
267             elsif ($ua) {
268 0 0       0 if ($ua =~ /win/i) {
    0          
    0          
269 0         0 return "windows-1250";
270             }
271             elsif ($ua =~ /(mac|m68m|ppc|mac)/i) {
272 0         0 return "apple-ce";
273             }
274             elsif ($ua =~ /os\/2|ibm-webexplorer|amiga|x11/i) {
275 0         0 return "iso-8859-2";
276             }
277             else {
278 0         0 return "us-ascii";
279             }
280             }
281             elsif ($lang) {
282 0 0       0 if ($lang =~ /cs|cz|sk/i) {
283 0         0 return "windows-1250";
284             }
285             else {
286 0         0 return "us-ascii";
287             }
288             }
289             else {
290 0         0 return "us-ascii";
291             }
292             }
293              
294              
295             sub lookup_charset {
296 6     6 0 13 my $name = lc($_[0]);
297 6         55 my %charsets = (
298             'us-ascii' => 0,
299             'iso-8859-1' => 1,
300             'iso-8859-2' => 2,
301             'windows-1250' => 3,
302             'kam' => 4,
303             'pclatin2' => 5,
304             'koi8cs' => 6,
305             'apple-ce' => 7,
306             'cp850' => 8,
307            
308             # non standard
309            
310             'ascii' => 0,
311             'unix' => 2,
312             'windows' => 3,
313             'win' => 3,
314             'kamenicti' => 4,
315             'macintosh' => 7,
316             'mac' => 7
317             );
318            
319 6 50       17 if (exists ($charsets{$name})) {
320 6         100 return $charsets{$name};
321             }
322             else {
323 0           croak
324             ("CzFast - Unknown charset $_[0]. Consult perldoc CzFast.");
325             }
326             }
327              
328              
329             bootstrap CzFast $VERSION;
330              
331              
332             1;
333             __END__