Fix Safari weirdness
parent
bb9d24c18a
commit
d9d5dcc7a6
|
@ -225,3 +225,5 @@ urls [
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ "foo#3" ] [ URL" foo" clone 3 >>anchor present ] unit-test
|
[ "foo#3" ] [ URL" foo" clone 3 >>anchor present ] unit-test
|
||||||
|
|
||||||
|
[ "http://www.foo.com/" ] [ "http://www.foo.com:80" >url present ] unit-test
|
||||||
|
|
|
@ -155,13 +155,30 @@ M: string >url
|
||||||
% password>> [ ":" % % ] when* "@" %
|
% password>> [ ":" % % ] when* "@" %
|
||||||
] [ 2drop ] if ;
|
] [ 2drop ] if ;
|
||||||
|
|
||||||
|
: protocol-port ( protocol -- port )
|
||||||
|
{
|
||||||
|
{ "http" [ 80 ] }
|
||||||
|
{ "https" [ 443 ] }
|
||||||
|
{ "feed" [ 80 ] }
|
||||||
|
{ "ftp" [ 21 ] }
|
||||||
|
[ drop f ]
|
||||||
|
} case ;
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
: url-port ( url -- port/f )
|
||||||
|
[ port>> ] [ port>> ] [ protocol>> protocol-port ] tri =
|
||||||
|
[ drop f ] when ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
: unparse-host-part ( url protocol -- )
|
: unparse-host-part ( url protocol -- )
|
||||||
%
|
%
|
||||||
"://" %
|
"://" %
|
||||||
{
|
{
|
||||||
[ unparse-username-password ]
|
[ unparse-username-password ]
|
||||||
[ host>> url-encode % ]
|
[ host>> url-encode % ]
|
||||||
[ port>> [ ":" % # ] when* ]
|
[ url-port [ ":" % # ] when* ]
|
||||||
[ path>> "/" head? [ "/" % ] unless ]
|
[ path>> "/" head? [ "/" % ] unless ]
|
||||||
} cleave ;
|
} cleave ;
|
||||||
|
|
||||||
|
@ -212,15 +229,6 @@ PRIVATE>
|
||||||
[ [ host>> ] [ port>> ] bi <inet> ] [ protocol>> ] bi
|
[ [ host>> ] [ port>> ] bi <inet> ] [ protocol>> ] bi
|
||||||
secure-protocol? [ <secure> ] when ;
|
secure-protocol? [ <secure> ] when ;
|
||||||
|
|
||||||
: protocol-port ( protocol -- port )
|
|
||||||
{
|
|
||||||
{ "http" [ 80 ] }
|
|
||||||
{ "https" [ 443 ] }
|
|
||||||
{ "feed" [ 80 ] }
|
|
||||||
{ "ftp" [ 21 ] }
|
|
||||||
[ drop f ]
|
|
||||||
} case ;
|
|
||||||
|
|
||||||
: ensure-port ( url -- url' )
|
: ensure-port ( url -- url' )
|
||||||
dup protocol>> '[ _ protocol-port or ] change-port ;
|
dup protocol>> '[ _ protocol-port or ] change-port ;
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue