Debbugs/URI.pm

   1 package Debbugs::URI;
   2
   3 =head1 NAME
   4
   5 Debbugs::URI -- Derivative of URI which overrides the query_param
   6  method to use ';' instead of '&' for separators.
   7
   8 =head1 SYNOPSIS
   9
  10 use Debbugs::URI;
  11
  12 =head1 DESCRIPTION
  13
  14 See L<URI> for more information.
  15
  16 =head1 BUGS
  17
  18 None known.
  19
  20 =cut
  21
  22 use warnings;
  23 use strict;
  24 use base qw(URI URI::_query);
  25
  26 =head2 query_param
  27
  28      $uri->query_form( $key1 => $val1, $key2 => $val2, ... )
  29
  30 Exactly like query_param in L<URI> except query elements are joined by
  31 ; instead of &.
  32
  33 =cut
  34
  35 {
  36
  37      package URI::_query;
  38
  39      no warnings 'redefine';
  40      # Handle ...?foo=bar&bar=foo type of query
  41      sub URI::_query::query_form {
  42           my $self = shift;
  43           my $old = $self->query;
  44           if (@_) {
  45                # Try to set query string
  46                my @new = @_;
  47                if (@new == 1) {
  48                     my $n = $new[0];
  49                     if (ref($n) eq "ARRAY") {
  50                          @new = @$n;
  51                     }
  52                     elsif (ref($n) eq "HASH") {
  53                          @new = %$n;
  54                     }
  55                }
  56                my @query;
  57                while (my($key,$vals) = splice(@new, 0, 2)) {
  58                     $key = '' unless defined $key;
  59                     $key =~ s/([;\/?:@&=+,\$\[\]%])/$URI::Escape::escapes{$1}/g;
  60                     $key =~ s/ /+/g;
  61                     $vals = [ref($vals) eq "ARRAY" ? @$vals : $vals];
  62                     for my $val (@$vals) {
  63                          $val = '' unless defined $val;
  64                          $val =~ s/([;\/?:@&=+,\$\[\]%])/$URI::Escape::escapes{$1}/g;
  65                          $val =~ s/ /+/g;
  66                          push(@query, "$key=$val");
  67                     }
  68                }
  69                # We've changed & to a ; here.
  70                $self->query(@query ? join(';', @query) : undef);
  71           }
  72           return if !defined($old) || !length($old) || !defined(wantarray);
  73           return unless $old =~ /=/; # not a form
  74           map { s/\+/ /g; uri_unescape($_) }
  75                # We've also changed the split here to split on ; as well as &
  76                map { /=/ ? split(/=/, $_, 2) : ($_ => '')} split(/[&;]/, $old);
  77      }
  78 }
  79
  80
  81
  82
  83
  84
  85 1;
  86
  87
  88 __END__
  89
  90
  91
  92
  93
  94