t/pathtools.t

   1 #!/usr/bin/perl
   2 use strict;
   3 use warnings;
   4 use Test::More tests => 304;
   5 use Test::MockModule;
   6
   7 # module compilation
   8 use Maypole;
   9
  10 # simple test class that inherits from Maypole
  11 {
  12     package MyDriver;
  13     @MyDriver::ISA = 'Maypole';
  14     @MyDriver::VERSION = 1;
  15 }
  16
  17 # back to package main;
  18 my $driver_class = 'MyDriver';
  19
  20 my $r = $driver_class->new;
  21
  22 # make_uri
  23 {
  24     my @bases = ( '/', '/foo', '/foo/', '', 'http://www.example.com',
  25                     'http://www.example.com/', 'http://www.example.com/foo',
  26                     'http://www.example.com/foo/', );
  27
  28     my $query = { string => 'baz',
  29                   number => 4,
  30                   list   => [ qw/ fee fi fo / ],
  31                   };
  32
  33     my $query_string = '?number=4&string=baz&list=fee&list=fi&list=fo';
  34
  35                  # expect       # send
  36     my @uris = (
  37                  { expect   =>'',
  38                    send     => [ '' ],
  39                    },
  40                  { expect   => '',
  41                    send     => [ () ],
  42                    },
  43                  { expect   => '/table',
  44                    send     => [ qw( table ) ],
  45                    },
  46                  { expect   => '/table/action',
  47                    send     => [ qw( table action ) ],
  48                    },
  49                  { expect   => '/table/action/id',
  50                    send     => [ qw( table action id ) ],
  51                    },
  52
  53
  54                  { expect   =>'',
  55                    send     => [ '', $query ],
  56                    },
  57                  { expect   => '',
  58                    send     => [ $query ],
  59                    },
  60                  { expect   => '/table',
  61                    send     => [ qw( table ), $query ],
  62                    },
  63                  { expect   => '/table/action',
  64                    send     => [ qw( table action ), $query ],
  65                    },
  66                  { expect   => '/table/action/id',
  67                    send     => [ qw( table action id ), $query ],
  68                    },
  69
  70                  );
  71
  72     foreach my $base (@bases)
  73     {
  74         $driver_class->config->uri_base($base);
  75
  76         (my $base_no_slash = $base) =~ s|/$||;
  77         my $base_or_slash = $base_no_slash || '/';
  78
  79         my $i = 1;
  80
  81         foreach my $test (@uris)
  82         {
  83             #diag "BASE: $base - URI #$i"; $i++;
  84
  85             my @s      = @{ $test->{send} };
  86             my $expect = $test->{expect};
  87
  88             my $uri = $r->make_uri(@s);
  89
  90             like("$uri", qr/^\Q$base_or_slash\E/,
  91                 "'$uri' starts with '$base_or_slash'");
  92
  93             my $q = ref $s[-1] ? $query_string : '';
  94
  95             my $msg =
  96                 sprintf "'%s' is '%s%s%s': base - '%s' segments - '%s'",
  97                         $uri, $base_no_slash, $expect, $q, $base,
  98                             @s ? join(', ', @s) : '()';
  99
 100             my $reconstructed = $expect =~ m|^/| ? "$base_no_slash$expect$q" :
 101                                                    "$base_or_slash$expect$q";
 102
 103             cmp_ok("$uri", 'eq', "$reconstructed" || '/', $msg);
 104         }
 105     }
 106 }
 107
 108 # make_path
 109 {
 110     my @bases = ( '/', '/foo', '/foo/', '', 'http://www.example.com',
 111                     'http://www.example.com/', 'http://www.example.com/foo',
 112                     'http://www.example.com/foo/', );
 113
 114     my $query = { string => 'baz',
 115                   number => 4,
 116                   list   => [ qw/ fee fi fo / ],
 117                   };
 118
 119     my $query_string = '?number=4&string=baz&list=fee&list=fi&list=fo';
 120
 121                  # expect       # send
 122     my @uris = (
 123                  { expect   => '/table/action',
 124                    send     => [ qw( table action ) ],
 125                    },
 126                  { expect   => '/table/action/id',
 127                    send     => [ qw( table action id ) ],
 128                    },
 129
 130
 131                  { expect   => '/table/action',
 132                    send     => [ qw( table action ), $query ],
 133                    },
 134                  );
 135
 136     foreach my $base (@bases)
 137     {
 138         $driver_class->config->uri_base($base);
 139
 140         (my $base_no_slash = $base) =~ s|/$||;
 141         my $base_or_slash = $base_no_slash || '/';
 142
 143         my $i = 1;
 144
 145         foreach my $test (@uris)
 146         {
 147             #diag "BASE: $base - URI #$i"; $i++;
 148
 149             my @args = @{ $test->{send} };
 150
 151             my %args = ( table  => $args[0],
 152                          action => $args[1],
 153                          additional => $args[2],
 154                          );
 155
 156             my %arg_sets = ( array => \@args,
 157                              hash  => \%args,
 158                              hashref => \%args,
 159                              );
 160
 161             my $expect = $test->{expect};
 162             my @s      = @{ $test->{send} };
 163
 164             foreach my $set (keys %arg_sets)
 165             {
 166
 167                 my $path;
 168                 $path = $r->make_path(@{ $arg_sets{$set} }) if $set eq 'array';
 169                 $path = $r->make_path(%{ $arg_sets{$set} }) if $set eq 'hash';
 170                 $path = $r->make_path($arg_sets{$set})   if $set eq 'hashref';
 171
 172                 like($path, qr/^\Q$base_or_slash\E/,
 173                     "'$path' starts with '$base_or_slash'");
 174
 175                 my $q = ref $s[-1] ? $query_string : '';
 176
 177                 my $msg =
 178                     sprintf "'%s' is '%s%s%s': base - '%s' segments - '%s'",
 179                             $path, $base_no_slash, $expect, $q, $base,
 180                                 @s ? join(', ', @s) : '()';
 181
 182                 my $reconstructed = $expect =~ m|^/|
 183                     ? "$base_no_slash$expect$q" :
 184                       "$base_or_slash$expect$q";
 185
 186                 cmp_ok($path, 'eq', "$reconstructed" || '/', $msg);
 187             }
 188         }
 189     }
 190 }
 191