tools/url-pattern-translator.pl

   1 #!/usr/bin/perl
   2
   3 ############################################################################
   4 #
   5 # url-pattern-translator
   6 #
   7 # Filters Privoxy action files and changes old-school URL patterns to
   8 # use extended regular expressions for the host as well.
   9 #
  10 # While it works good enough to satisfy the regression tests in
  11 # default.action.master, it isn't perfect and you should double-check
  12 # the output and keep backups of your old action files.
  13 #
  14 # Usage:
  15 #
  16 # url-pattern-translator.pl old.action > new.action
  17 #
  18 # Only convert your files once, or, as RoboCop used to say,
  19 # there will be... trouble.
  20 #
  21 # $Id: url-pattern-translator.pl 1.10 2008/08/10 16:32:59 fk Exp $
  22 #
  23 # Copyright (c) 2008 Fabian Keil <fk@fabiankeil.de>
  24 #
  25 # Permission to use, copy, modify, and distribute this software for any
  26 # purpose with or without fee is hereby granted, provided that the above
  27 # copyright notice and this permission notice appear in all copies.
  28 #
  29 # THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
  30 # WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
  31 # MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
  32 # ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
  33 # WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
  34 # ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
  35 # OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  36 #
  37 ############################################################################
  38
  39 use strict;
  40 use warnings;
  41
  42 sub p ($) {
  43     my $message = shift;
  44     print $message . "\n";
  45 }
  46
  47 sub convert_host_pattern ($) {
  48     my $host_pattern = shift;
  49     my $hp = $host_pattern;
  50
  51     $hp =~ s@\s@@g;
  52
  53     if ($hp =~ m@^\.@) {
  54         # Not left-anchored
  55         #
  56         # XXX: This is somewhat ugly and while it's
  57         # the equivalent pattern in most cases
  58         # \. should be good enough.
  59         $hp =~ s@^\.@(^|.)@;
  60     } else {
  61         # left-anchored
  62         $hp = '^' . $hp;
  63     }
  64
  65     # Match-all syntax has changed ...
  66     $hp =~ s@\*@.*@g;
  67
  68     # Extended host patterns are right-anchored by default
  69     $hp =~ s@\.$@(\..*)?@;
  70
  71     # Literal dots have to be escaped
  72     $hp =~ s@((?<!\\)\.[^*])@\\$1@g;
  73
  74     # Match single character with a dot.
  75     $hp =~ s@(?<!\))\?@.@g;
  76
  77     return $hp;
  78 }
  79
  80 sub looks_interesting($) {
  81     my $line = shift;
  82     my $type_to_skip = undef;
  83
  84     if (/^\s*\#/) {
  85
  86         $type_to_skip = "comment";
  87
  88     } elsif (/[{}]/ or /\\$/) {
  89
  90         $type_to_skip = "action settings";
  91
  92     } elsif (m@^\s*$@) {
  93
  94         $type_to_skip = "whitespace";
  95
  96     } elsif (m@^\s*TAG:@) {
  97
  98         $type_to_skip = "tag patttern";
  99
 100     } elsif (m@^[^/]*=@) {
 101
 102         $type_to_skip = "macro or version definition";
 103
 104     }
 105
 106     #p("Skipping " . $type_to_skip . ": " . $_);
 107
 108     return not defined $type_to_skip;
 109 }
 110
 111 sub main () {
 112     my $host = undef;
 113     my $path = undef;
 114
 115     while (<>) {
 116         chomp;
 117
 118         if (looks_interesting($_)) {
 119             if (m@^([^/]+)(/.*)$@) {
 120                 $host = $1;
 121                 $path = $2;
 122                 $host = convert_host_pattern($host);
 123                 $_ = $host . $path;
 124             }
 125             elsif (m@^([^/]*)$@) {
 126                 $host = $1;
 127                 $host = convert_host_pattern($host);
 128                 $_ = $host;
 129             }
 130         }
 131         p($_);
 132     }
 133 }
 134
 135 main();