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     my @uris = (
  36                  { expect   =>'',
  37                    send     => [ '' ],
  38                    },
  39                  { expect   => '',
  40                    send     => [ () ],
  41                    },
  42                  { expect   => '/table',
  43                    send     => [ qw( table ) ],
  44                    },
  45                  { expect   => '/table/action',
  46                    send     => [ qw( table action ) ],
  47                    },
  48                  { expect   => '/table/action/id',
  49                    send     => [ qw( table action id ) ],
  50                    },
  51
  52
  53                  { expect   =>'',
  54                    send     => [ '', $query ],
  55                    },
  56                  { expect   => '',
  57                    send     => [ $query ],
  58                    },
  59                  { expect   => '/table',
  60                    send     => [ qw( table ), $query ],
  61                    },
  62                  { expect   => '/table/action',
  63                    send     => [ qw( table action ), $query ],
  64                    },
  65                  { expect   => '/table/action/id',
  66                    send     => [ qw( table action id ), $query ],
  67                    },
  68
  69                  );
  70
  71     foreach my $base (@bases)
  72     {
  73         $driver_class->config->uri_base($base);
  74
  75         (my $base_no_slash = $base) =~ s|/$||;
  76         my $base_or_slash = $base_no_slash || '/';
  77
  78         my $i = 1;
  79
  80         foreach my $test (@uris)
  81         {
  82             #diag "BASE: $base - URI #$i"; $i++;
  83
  84             my @s      = @{ $test->{send} };
  85             my $expect = $test->{expect};
  86
  87             my $uri = $r->make_uri(@s);
  88
  89             like("$uri", qr/^\Q$base_or_slash\E/,
  90                 "'$uri' starts with '$base_or_slash'");
  91
  92             my $q = ref $s[-1] ? $query_string : '';
  93
  94             my $msg =
  95                 sprintf "'%s' is '%s%s%s': base - '%s' segments - '%s'",
  96                         $uri, $base_no_slash, $expect, $q, $base,
  97                             @s ? join(', ', @s) : '()';
  98
  99             my $reconstructed = $expect =~ m|^/| ? "$base_no_slash$expect$q" :
 100                                                    "$base_or_slash$expect$q";
 101
 102             cmp_ok("$uri", 'eq', "$reconstructed" || '/', $msg);
 103         }
 104     }
 105 }
 106
 107 # make_path
 108 {
 109     my @bases = ( '/', '/foo', '/foo/', '', 'http://www.example.com',
 110                     'http://www.example.com/', 'http://www.example.com/foo',
 111                     'http://www.example.com/foo/', );
 112
 113     my $query = { string => 'baz',
 114                   number => 4,
 115                   list   => [ qw/ fee fi fo / ],
 116                   };
 117
 118     my $query_string = '?number=4&string=baz&list=fee&list=fi&list=fo';
 119
 120                  # expect       # send
 121     my @uris = (
 122                  { expect   => '/table/action',
 123                    send     => [ qw( table action ) ],
 124                    },
 125                  { expect   => '/table/action/id',
 126                    send     => [ qw( table action id ) ],
 127                    },
 128
 129
 130                  { expect   => '/table/action',
 131                    send     => [ qw( table action ), $query ],
 132                    },
 133                  );
 134
 135     foreach my $base (@bases)
 136     {
 137         $driver_class->config->uri_base($base);
 138
 139         (my $base_no_slash = $base) =~ s|/$||;
 140         my $base_or_slash = $base_no_slash || '/';
 141
 142         my $i = 1;
 143
 144         foreach my $test (@uris)
 145         {
 146             #diag "BASE: $base - URI #$i"; $i++;
 147
 148             my @args = @{ $test->{send} };
 149
 150             my %args = ( table  => $args[0],
 151                          action => $args[1],
 152                          additional => $args[2],
 153                          );
 154
 155             my %arg_sets = ( array => \@args,
 156                              hash  => \%args,
 157                              hashref => \%args,
 158                              );
 159
 160             my $expect = $test->{expect};
 161             my @s      = @{ $test->{send} };
 162
 163             foreach my $set (keys %arg_sets)
 164             {
 165
 166                 my $path;
 167                 $path = $r->make_path(@{ $arg_sets{$set} }) if $set eq 'array';
 168                 $path = $r->make_path(%{ $arg_sets{$set} }) if $set eq 'hash';
 169                 $path = $r->make_path($arg_sets{$set})   if $set eq 'hashref';
 170
 171                 like($path, qr/^\Q$base_or_slash\E/,
 172                     "'$path' starts with '$base_or_slash'");
 173
 174                 my $q = ref $s[-1] ? $query_string : '';
 175
 176                 my $msg =
 177                     sprintf "'%s' is '%s%s%s': base - '%s' segments - '%s'",
 178                             $path, $base_no_slash, $expect, $q, $base,
 179                                 @s ? join(', ', @s) : '()';
 180
 181                 my $reconstructed = $expect =~ m|^/|
 182                     ? "$base_no_slash$expect$q" :
 183                       "$base_or_slash$expect$q";
 184
 185                 cmp_ok($path, 'eq', "$reconstructed" || '/', $msg);
 186             }
 187         }
 188     }
 189 }
 190