1 |
dpavlin |
1.1 |
package Apache::czs; |
2 |
|
|
|
3 |
|
|
use strict; |
4 |
|
|
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); |
5 |
|
|
|
6 |
dpavlin |
1.2 |
$VERSION = '0.03'; |
7 |
dpavlin |
1.1 |
|
8 |
|
|
use Apache::Constants qw(:common :response); |
9 |
|
|
|
10 |
|
|
my $DEBUG = 1; |
11 |
|
|
|
12 |
|
|
sub handler { |
13 |
|
|
my $r = shift; |
14 |
|
|
|
15 |
|
|
my $Status = NOT_FOUND; |
16 |
|
|
my $charset; |
17 |
|
|
|
18 |
|
|
my $fn=$r->filename; |
19 |
|
|
|
20 |
|
|
my $fh = $r->gensym; |
21 |
|
|
$r->register_cleanup(sub {close $fh}); |
22 |
|
|
|
23 |
|
|
return DECLINED if # don't scan the file if.. |
24 |
|
|
!$r->is_main # a subrequest |
25 |
|
|
|| $r->content_type ne "text/html"; # it isn't HTML |
26 |
|
|
return NOT_FOUND unless open($fh, $fn); # we can't open it |
27 |
|
|
|
28 |
|
|
# local($/) = "\n"; |
29 |
|
|
local $/; |
30 |
|
|
|
31 |
|
|
my $content = <$fh>; |
32 |
|
|
|
33 |
|
|
my $ua = $r->header_in('User-Agent'); |
34 |
|
|
|
35 |
|
|
$charset = "iso-8859-2"; |
36 |
|
|
|
37 |
|
|
$content =~ s,text/html; charset=iso-8859-2,text/html,gi; |
38 |
|
|
|
39 |
|
|
if ($ENV{DO_CZS}) { |
40 |
|
|
$content =~ tr,¹ðè澩ÐÈÆ®,sdcczSDCCZ,; |
41 |
|
|
$charset = "iso-8859-1"; |
42 |
|
|
} |
43 |
|
|
|
44 |
|
|
if ($ENV{DO_XMAC}) { |
45 |
|
|
$charset = "x-mac-roman"; |
46 |
|
|
} elsif ($ENV{DO_MACCE}) { |
47 |
|
|
$charset = "MacCE"; |
48 |
dpavlin |
1.2 |
} elsif (!$ENV{DO_CZS} && $ua =~ m,Mac,i && $r->method eq 'GET') { |
49 |
dpavlin |
1.1 |
my $uri; |
50 |
|
|
if ($ua =~ m,MSIE,i) { |
51 |
|
|
$uri="/xmac"; |
52 |
|
|
} else { |
53 |
|
|
$uri="/macce"; |
54 |
|
|
} |
55 |
|
|
$uri .= $r->uri; |
56 |
|
|
$uri .= "?".$r->args if ($r->args); |
57 |
|
|
$r->warn("go to mac $uri") if ($DEBUG); |
58 |
|
|
$r->uri($uri); |
59 |
|
|
$r->content_type("text/html"); |
60 |
|
|
$r->header_out(Location => $uri); |
61 |
|
|
$r->header_out(URI => $uri); |
62 |
|
|
$r->status(REDIRECT); |
63 |
|
|
return REDIRECT; |
64 |
|
|
} |
65 |
|
|
|
66 |
|
|
|
67 |
|
|
if ($charset) { |
68 |
|
|
$r->content_type("text/html; charset=$charset"); |
69 |
|
|
} |
70 |
|
|
|
71 |
|
|
$r->warn("$ua $charset") if ($DEBUG); |
72 |
|
|
|
73 |
|
|
$r->send_http_header; |
74 |
|
|
|
75 |
|
|
$content.="\n<!-- ".$r->header_in('User-Agent')." -- $charset -->\n" if ($DEBUG); |
76 |
|
|
|
77 |
|
|
|
78 |
|
|
$r->print($content); |
79 |
|
|
|
80 |
|
|
return OK; |
81 |
|
|
|
82 |
|
|
} |
83 |
|
|
|
84 |
|
|
sub trans { |
85 |
|
|
my $r = shift; |
86 |
|
|
|
87 |
|
|
my $uri = $r->uri; |
88 |
|
|
my $ua = $r->header_in('User-Agent'); |
89 |
|
|
|
90 |
|
|
if ($uri =~ s/\/czs\//\//i) { |
91 |
|
|
$r->subprocess_env('DO_CZS' => 1); |
92 |
|
|
} elsif ($uri =~ s/\/xmac\//\//i) { |
93 |
|
|
$r->subprocess_env('DO_XMAC' => 1); |
94 |
|
|
} elsif ($uri =~ s/\/macce\//\//i) { |
95 |
|
|
$r->subprocess_env('DO_MACCE' => 1); |
96 |
|
|
} |
97 |
|
|
|
98 |
|
|
$r->uri($uri); |
99 |
|
|
return DECLINED; |
100 |
|
|
} |
101 |
|
|
|
102 |
|
|
1; |
103 |
|
|
__END__ |
104 |
|
|
|
105 |
|
|
=head1 NAME |
106 |
|
|
|
107 |
|
|
Apache::czs - does magic with Croatian characters |
108 |
|
|
|
109 |
|
|
=head1 SYNOPSIS |
110 |
|
|
|
111 |
|
|
PerlTransHandler Apache::czs::trans |
112 |
dpavlin |
1.2 |
<Files ~ "\.htm" > |
113 |
dpavlin |
1.1 |
SetHandler perl-script |
114 |
|
|
PerlModule Apache::czs |
115 |
|
|
PerlHandler Apache::czs::handler |
116 |
dpavlin |
1.2 |
</Files> |
117 |
dpavlin |
1.1 |
|
118 |
|
|
=head1 DESCRIPTION |
119 |
|
|
|
120 |
|
|
Modifies pages based on URL and/or User-Agent. |
121 |
|
|
|
122 |
|
|
- redirects Machintosh users to virutal URLs /macce/ and /xmac/ based |
123 |
|
|
on thair User-Agent (Netscape, IE) and charset (to be friendly to |
124 |
|
|
cache engines) |
125 |
|
|
|
126 |
|
|
- supports virtual URL /czs/ for removing Croatian characters (and |
127 |
|
|
setting character set to iso-8859-1) |
128 |
|
|
|
129 |
|
|
- removes META charset from html document |
130 |
|
|
|
131 |
|
|
|
132 |
|
|
=head1 AUTHOR |
133 |
|
|
|
134 |
|
|
Dobrica Pavlinusic <dpavlin@rot13.org> |
135 |
|
|
|
136 |
|
|
=head1 SEE ALSO |
137 |
|
|
|
138 |
|
|
perl(1), apache(1). |
139 |
|
|
|
140 |
|
|
=cut |