latin-1.pl

   1 #! /usr/bin/perl
   2 # Copyright (C) 2004  Alex Schroeder <alex@emacswiki.org>
   3 #
   4 # This program is free software; you can redistribute it and/or modify
   5 # it under the terms of the GNU General Public License as published by
   6 # the Free Software Foundation; either version 2 of the License, or
   7 # (at your option) any later version.
   8 #
   9 # This program is distributed in the hope that it will be useful,
  10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 # GNU General Public License for more details.
  13 #
  14 # You should have received a copy of the GNU General Public License
  15 # along with this program; if not, write to the
  16 #    Free Software Foundation, Inc.
  17 #    59 Temple Place, Suite 330
  18 #    Boston, MA 02111-1307 USA
  19
  20 use CGI qw/:standard/;
  21 use CGI::Carp qw(fatalsToBrowser);
  22 use Encode;
  23
  24 sub translate {
  25   my $str = shift;
  26   $str = encode('latin-1', decode('utf-8', $str));
  27   my @letters = split(//, $str);
  28   my @safe = ('a' .. 'z', 'A' .. 'Z', '0' .. '9', '-', '_', '.', '!', '~', '*', "'", '(', ')',
  29               ':', '/', '?', ';', '&');
  30   foreach my $letter (@letters) {
  31     my $pattern = quotemeta($letter);
  32     if (not grep(/$pattern/, @safe)) {
  33       $letter = uc(sprintf("%%%02x", ord($letter)));
  34     }
  35   }
  36   return join('', @letters);
  37 }
  38
  39 if (not param('url')) {
  40   print header(),
  41     start_html('UTF-8 to Latin-1 Escapes'),
  42     h1('UTF-8 to Latin-1 Escapes'),
  43     p('Translates URLs containing URL-encoded UTF-8 to ',
  44       'URLs  containing URL-encoded Latin-1 and redirects to it.'),
  45     start_form(-method=>'GET'),
  46     p('URL: ', textfield('url', '', 70)),
  47     p(submit()),
  48     end_form(),
  49     end_html();
  50   exit;
  51 }
  52
  53 my $str = param('url');
  54
  55 print redirect(translate($str));
  56
  57 # print $str, "\n";
  58 # print translate($str), "\n";
  59
  60 # perl latin-1.pl url=http://wiki.crao.net/index.php/Communaut%C3%A9Crao