$Bio::EnsEMBL::Utils::URI::VERSION
=
'112.0_55'
;
$Bio::EnsEMBL::Utils::URI::VERSION
=
'112.055'
;
our
$URI_ESCAPE
;
$URI_ESCAPE
= 0;
eval
{
URI::Escape->
import
();
$URI_ESCAPE
= 1;
};
our
@EXPORT_OK
;
our
%EXPORT_TAGS
;
@EXPORT_OK
=
qw/parse_uri is_uri/
;
%EXPORT_TAGS
= (
all
=> [
@EXPORT_OK
] );
sub
is_uri {
my
(
$uri
) =
@_
;
return
0
if
!
$uri
;
my
$SCHEME
=
qr{ ([^:]*) :// }
xms;
return
(
$uri
=~
$SCHEME
) ? 1 : 0;
}
sub
parse_uri {
my
(
$url
) =
@_
;
my
$SCHEME
=
qr{ ([^:]*) :// }
xms;
my
$USER
=
qr{ ([^/:\@]+)? :? ([^/\@]+)? \@ }
xms;
my
$HOST
=
qr{ ([^/:]+)? :? ([^/]+)? }
xms;
my
$DB
=
qr{ / ([^/?]+)? /? ([^/?]+)? }
xms;
my
$PARAMS
=
qr{ \? (.+)}
xms;
my
$p
;
if
(
$url
=~
qr{ $SCHEME ([^?]+) (?:$PARAMS)? }
xms) {
my
$scheme
= $1;
$scheme
= (
$URI_ESCAPE
) ? uri_unescape(
$scheme
) :
$scheme
;
$p
= Bio::EnsEMBL::Utils::URI->new(
$scheme
);
my
(
$locator
,
$params
) = ($2, $3);
if
(
$scheme
eq
'file'
) {
$p
->path(
$locator
);
}
elsif
(
$scheme
eq
'sqlite'
) {
$p
->path(
$locator
);
}
else
{
if
(
$locator
=~ s/^
$USER
//) {
$p
->user($1);
$p
->pass($2);
}
if
(
$locator
=~ s/^
$HOST
//) {
$p
->host((
$URI_ESCAPE
) ? uri_unescape($1) : $1);
$p
->port((
$URI_ESCAPE
) ? uri_unescape($2) : $2);
}
if
(
$p
->is_db_scheme() ||
$scheme
eq
q{}
) {
if
(
$locator
=~
$DB
) {
$p
->db_params()->{dbname} = (
$URI_ESCAPE
) ? uri_unescape($1) : $1;
$p
->db_params()->{table} = (
$URI_ESCAPE
) ? uri_unescape($2) : $2;
}
}
else
{
$p
->path(
$locator
);
}
}
if
(
defined
$params
) {
my
@kv_pairs
=
split
(/;|&/,
$params
);
foreach
my
$kv_string
(
@kv_pairs
) {
my
(
$key
,
$value
) =
map
{ (
$URI_ESCAPE
) ? uri_unescape(
$_
) :
$_
}
split
(/=/,
$kv_string
);
$p
->add_param(
$key
,
$value
);
}
}
}
return
$p
;
}
sub
new {
my
(
$class
,
$scheme
) =
@_
;
$class
=
ref
(
$class
) ||
$class
;
throw
"Scheme cannot be undefined. Empty string is allowed"
if
!
defined
$scheme
;
my
$self
=
bless
({
params
=> {},
param_keys
=> [],
db_params
=> {},
scheme
=>
$scheme
,
},
$class
);
return
$self
;
}
sub
db_schemes {
my
(
$self
) =
@_
;
return
{
map
{
$_
=> 1 }
qw/mysql ODBC sqlite Oracle Sybase/
};
}
sub
is_db_scheme {
my
(
$self
) =
@_
;
return
(
exists
$self
->db_schemes()->{
$self
->scheme()} ) ? 1 : 0;
}
sub
scheme {
my
(
$self
) =
@_
;
return
$self
->{scheme};
}
sub
path {
my
(
$self
,
$path
) =
@_
;
$self
->{path} =
$path
if
defined
$path
;
return
$self
->{path};
}
sub
user {
my
(
$self
,
$user
) =
@_
;
$self
->{user} =
$user
if
defined
$user
;
return
$self
->{user};
}
sub
pass {
my
(
$self
,
$pass
) =
@_
;
$self
->{pass} =
$pass
if
defined
$pass
;
return
$self
->{pass};
}
sub
host {
my
(
$self
,
$host
) =
@_
;
$self
->{host} =
$host
if
defined
$host
;
return
$self
->{host};
}
sub
port {
my
(
$self
,
$port
) =
@_
;
if
(
defined
$port
) {
if
(! looks_like_number(
$port
) ||
$port
< 1 ||
int
(
$port
) !=
$port
) {
throw
"Port $port is not a number, less than 1 or not a whole integer"
;
}
$self
->{port} =
$port
if
defined
$port
;
}
return
$self
->{port};
}
sub
param_keys {
my
(
$self
) =
@_
;
return
[@{
$self
->{param_keys}}];
}
sub
param_exists_ci {
my
(
$self
,
$key
) =
@_
;
my
%keys
=
map
{
uc
(
$_
) => 1 } @{
$self
->param_keys()};
return
(
$keys
{
uc
(
$key
)}) ? 1 : 0;
}
sub
add_param {
my
(
$self
,
$key
,
$value
) =
@_
;
if
(!
exists
$self
->{params}->{
$key
}) {
$self
->{params}->{
$key
} = [];
push
(@{
$self
->{param_keys}},
$key
);
}
push
(@{
$self
->{params}->{
$key
}},
$value
);
return
;
}
sub
get_params {
my
(
$self
,
$key
) =
@_
;
return
[]
if
!
exists
$self
->{params}->{
$key
};
return
[@{
$self
->{params}->{
$key
}}];
}
sub
db_params {
my
(
$self
) =
@_
;
return
$self
->{db_params};
}
sub
generate_dbsql_params {
my
(
$self
,
$no_table
) =
@_
;
my
%db_params
;
$db_params
{-DRIVER} =
$self
->scheme();
$db_params
{-HOST} =
$self
->host()
if
$self
->host();
$db_params
{-PORT} =
$self
->port()
if
$self
->port();
$db_params
{-USER} =
$self
->user()
if
$self
->user();
$db_params
{-PASS} =
$self
->pass()
if
$self
->pass();
my
$dbname
;
my
$table
;
if
(
$self
->scheme() eq
'sqlite'
) {
(
$dbname
,
$table
) =
$self
->_decode_sqlite();
}
else
{
$dbname
=
$self
->db_params()->{dbname};
$table
=
$self
->db_params()->{table};
}
$db_params
{-DBNAME} =
$dbname
if
$dbname
;
$db_params
{-TABLE} =
$table
if
!
$no_table
&&
$table
;
foreach
my
$boolean_param
(
qw/disconnect_when_inactive reconnect_when_connection_lost is_multispecies no_cache verbose/
) {
if
(
$self
->param_exists_ci(
$boolean_param
)) {
$db_params
{
q{-}
.
uc
(
$boolean_param
)} = 1;
}
}
foreach
my
$value_param
(
qw/species group species_id wait_timeout/
) {
if
(
$self
->param_exists_ci(
$value_param
)) {
$db_params
{
q{-}
.
uc
(
$value_param
)} =
$self
->get_params(
$value_param
)->[0];
}
}
return
%db_params
;
}
sub
_decode_sqlite {
my
(
$self
) =
@_
;
my
$dbname
;
my
$table
;
my
$path
=
$self
->path();
if
(-f
$path
) {
$dbname
=
$path
;
}
else
{
my
(
$volume
,
$directories
,
$file
) = File::Spec->splitpath(
$path
);
my
@splitdirs
= File::Spec->splitdir(
$directories
);
if
(
@splitdirs
== 1) {
$dbname
=
$path
;
}
else
{
my
$new_file
=
pop
(
@splitdirs
);
$new_file
||=
q{}
;
my
$new_path
= File::Spec->catpath(
$volume
, File::Spec->catdir(
@splitdirs
),
$new_file
);
if
(
$new_path
ne File::Spec->rootdir() && -f
$new_path
) {
$dbname
=
$new_path
;
$table
=
$file
;
}
else
{
$dbname
=
$path
;
}
}
}
$self
->db_params()->{dbname} =
$dbname
if
$dbname
;
$self
->db_params()->{table} =
$table
if
$table
;
return
(
$dbname
,
$table
);
}
sub
generate_uri {
my
(
$self
) =
@_
;
my
$scheme
=
sprintf
(
'%s://'
, (
$URI_ESCAPE
) ? uri_escape(
$self
->scheme()) :
$self
->scheme());
my
$user_credentials
=
q{}
;
my
$host_credentials
=
q{}
;
my
$location
=
q{}
;
if
(
$self
->user() ||
$self
->pass()) {
my
$user
=
$self
->user();
my
$pass
=
$self
->pass();
if
(
$URI_ESCAPE
) {
$user
= uri_escape(
$user
)
if
$user
;
$pass
= uri_escape(
$pass
)
if
$pass
;
}
$user_credentials
=
sprintf
(
'%s%s@'
,
(
$user
?
$user
:
q{}
),
(
$pass
?
q{:}
.
$pass
:
q{}
)
);
}
if
(
$self
->host() ||
$self
->port()) {
my
$host
=
$self
->host();
my
$port
=
$self
->port();
if
(
$URI_ESCAPE
) {
$host
= uri_escape(
$host
)
if
$host
;
$port
= uri_escape(
$port
)
if
$port
;
}
$host_credentials
=
sprintf
(
'%s%s'
,
(
$host
?
$host
:
q{}
),
(
$port
?
q{:}
.
$port
:
q{}
)
);
}
if
(
$self
->is_db_scheme() ||
$self
->scheme() eq
''
) {
if
(
$self
->scheme() eq
'sqlite'
) {
if
(!
$self
->path()) {
my
$tmp_loc
=
$self
->db_params()->{dbname};
throw
"There is no dbname available"
unless
$tmp_loc
;
$tmp_loc
.=
q{/}
.
$self
->db_params()->{table}
if
$self
->db_params()->{table};
$self
->path(
$tmp_loc
);
}
$location
=
$self
->path();
}
else
{
my
$dbname
=
$self
->db_params()->{dbname};
my
$table
=
$self
->db_params()->{table};
if
(
$dbname
||
$table
) {
if
(
$URI_ESCAPE
) {
$dbname
= uri_escape(
$dbname
)
if
$dbname
;
$table
= uri_escape(
$table
)
if
$table
;
}
$location
=
sprintf
(
'/%s%s'
,
(
$dbname
?
$dbname
:
q{}
),
(
$table
?
q{/}
.
$table
:
q{}
)
);
}
}
}
else
{
$location
=
$self
->path()
if
$self
->path();
}
my
$param_string
=
q{}
;
if
(@{
$self
->param_keys()}) {
$param_string
=
q{?}
;
my
@params
;
foreach
my
$key
(@{
$self
->param_keys}) {
my
$values_array
=
$self
->get_params(
$key
);
foreach
my
$value
(@{
$values_array
}) {
my
$encoded_key
= (
$URI_ESCAPE
) ? uri_escape(
$key
) :
$key
;
my
$encoded_value
= (
$URI_ESCAPE
) ? uri_escape(
$value
) :
$value
;
push
(
@params
, (
$encoded_value
) ?
"$encoded_key=$encoded_value"
:
$encoded_key
);
}
}
$param_string
.=
join
(
q{;}
,
@params
);
}
return
join
(
q{}
,
$scheme
,
$user_credentials
,
$host_credentials
,
$location
,
$param_string
);
}
1;