File Coverage

blib/lib/URI/_db.pm
Criterion Covered Total %
statement 53 53 100.0
branch 18 18 100.0
condition 2 3 66.6
subroutine 16 16 100.0
pod 1 10 10.0
total 90 100 90.0


line stmt bran cond sub pod time code
1             package URI::_db;
2              
3 3     3   19 use strict;
  3         6  
  3         104  
4 3     3   56 use 5.008001;
  3         12  
5 3     3   14 use base 'URI::_login';
  3         13  
  3         1520  
6             our $VERSION = '0.23';
7              
8 934     934 0 505769 sub uri { shift }
9 5     5   425 sub _no_scheme_ok { 0 }
10              
11 416     416 0 355846 sub canonical_engine { shift->scheme }
12              
13             sub canonical {
14 53     53 1 5509 my $canon = shift->SUPER::canonical;
15 53         1344 my $engine = $canon->canonical_engine;
16 53 100       475 return $canon if $canon->scheme eq $engine;
17 17         469 $canon = $canon->clone;
18 17         179 $canon->scheme($engine);
19 17         2871 return $canon;
20             }
21              
22             sub engine {
23 950     950 0 306260 my $self = shift;
24 950 100       6338 return $self->scheme unless @_;
25 6         22 my $old = $self->scheme(@_);
26 6 100       2210 bless $self => 'URI::_db' unless $self->isa('URI::_db');
27 6         35 return $old;
28             }
29              
30             sub has_recognized_engine {
31 97     97 0 242933 ref $_[0] ne __PACKAGE__;
32             }
33              
34             sub dbname {
35 1144     1144 0 93886 my $self = shift;
36 1144         5402 my $is_full = $self->opaque =~ m{^//(?://|/?(?!/))};
37 1144 100 66     23323 return $self->path($is_full && defined $_[0] ? "/$_[0]" : shift) if @_;
    100          
38 1134 100       4989 my @segs = $self->path_segments or return;
39 807 100       44120 shift @segs if $is_full;
40 807         5662 join '/' => @segs;
41             }
42              
43             sub query_params {
44 1148     1148 0 2864426 my $self = shift;
45 1148         10681 require URI::QueryParam;
46             return map {
47 1148         6046 my $f = $_;
  229         12903  
48 229         736 map { $f => $_ } grep { defined } $self->query_param($f)
  323         1567  
  323         28383  
49             } $self->query_param;
50             }
51              
52             sub _dbi_param_map {
53 64     64   3892 my $self = shift;
54             return (
55 64         259 [ host => scalar $self->host ],
56             [ port => scalar $self->_port ],
57             [ dbname => scalar $self->dbname ],
58             );
59             }
60              
61             sub dbi_params {
62 171     171 0 1139 my $self = shift;
63             return (
64             (
65 275         350 map { @{ $_ } }
  275         872  
66 171 100       412 grep { defined $_->[1] && length $_->[1] } $self->_dbi_param_map
  373         2814  
67             ),
68             $self->query_params,
69             );
70             }
71              
72 1     1 0 6 sub dbi_driver { return undef }
73              
74             sub _dsn_params {
75 89     89   193 my $self = shift;
76 89         187 my @params = $self->dbi_params;
77 89         1877 my @kvpairs;
78 89         237 while (@params) {
79 210         696 push @kvpairs => join '=', shift @params, shift @params;
80             }
81 89         814 return join ';' => @kvpairs;
82             }
83              
84             sub dbi_dsn {
85 86     86 0 48701 my $self = shift;
86 86 100       357 my $driver = $self->dbi_driver or return $self->_dsn_params;
87 85         334 return join ':' => 'dbi', $driver, $self->_dsn_params;
88             }
89              
90             1;