[dw-free] Helper function to create URLs

[fu]

[commit: http://hg.dwscoalition.org/dw-free/rev/518b72120000]

http://bugs.dwscoalition.org/show_bug.cgi?id=3017

Add an LJ::create_url helper function, which creates a URL to be printed on
the page, based on the page URL, and carrying over various GET arguments.

Patch by exor674.

Files modified:

• cgi-bin/weblib.pl
• t/create-url.t

--------------------------------------------------------------------------------
diff -r 9166db025b2d -r 518b72120000 cgi-bin/weblib.pl
--- a/cgi-bin/weblib.pl	Thu Sep 09 19:16:43 2010 +0800
+++ b/cgi-bin/weblib.pl	Thu Sep 09 19:24:25 2010 +0800
@@ -966,6 +966,61 @@ sub viewing_style_opts {
     }
 
     return \%ret;
+}
+
+=head2 C<< LJ::create_url($path,%opts) >>
+If specified, path must begin with a /
+
+args being a list of arguments to create.
+opts can contain:
+host -- link to different domains
+args -- get arguments to add
+ssl -- use ssl
+fragment -- add fragment identifier
+cur_args -- hashref of current GET arguments to the page
+keep_args -- arguments to keep
+viewing_style -- include viewing style args
+=cut
+
+sub create_url {
+    my ( $path, %opts ) = @_;
+
+    my $r = DW::Request->get;
+    my %out_args = %{ $opts{args} || {} };
+
+    my $host = $opts{host} || $r->header_in("Host");
+    $path ||= $r->uri;
+
+    # Default SSL if SSL is set and we are on the same host, unless we explicitly don't want it
+    $opts{ssl} = $LJ::IS_SSL unless $opts{host} || exists $opts{ssl};
+
+    my $url = ( $opts{ssl} ? "https" : "http" ) . "://$host$path";
+    $url .= "#" . $opts{fragment} if $opts{fragment};
+
+    my $orig_args = $opts{cur_args} || DW::Request->get->get_args;
+
+    # Move over viewing style arguments
+    if( $opts{viewing_style} ) {
+        my $vs_args = LJ::viewing_style_opts( %$orig_args );
+        foreach my $k ( keys %$vs_args ) {
+            $out_args{$k} = $vs_args->{$k} unless exists $out_args{$k};
+        }
+    }
+
+    # Move over arguments that we need to keep
+    foreach my $k ( @{$opts{keep_args}} ) {
+        $out_args{$k} = $orig_args->{$k} if exists $orig_args->{$k} && ! exists $out_args{$k};
+    }
+
+    foreach my $k ( keys %out_args ) {
+        delete $out_args{$k} unless defined $out_args{$k};
+    }
+
+    my $args = encode_url_string( \%out_args );
+
+    $url .= "?$args" if $args;
+
+    return $url;
 }
 
 # <LJFUNC>
diff -r 9166db025b2d -r 518b72120000 t/create-url.t
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/t/create-url.t	Thu Sep 09 19:24:25 2010 +0800
@@ -0,0 +1,221 @@
+# -*-perl-*-
+use strict;
+use Test::More tests => 5 * 14; # replace last number with the number of check_req calls
+use lib "$ENV{LJHOME}/cgi-bin";
+
+require 'ljlib.pl';
+use DW::Request::Standard;
+use HTTP::Request;
+
+check_req(
+    "http://www.example.com/",
+    undef, {
+        args => {
+            foo => "bar"
+        },
+    },
+    { ssl => 0, host => "www.example.com", uri=>"/", },
+    { foo => "bar", },
+);
+
+check_req(
+    "http://www.example.com/?bar=baz",
+    undef, {
+        args => {
+            foo => 'bar',
+        },
+        keep_args => [ 'bar' ],
+    },
+    { ssl => 0, host => "www.example.com", uri=>"/", },
+    {
+        foo => "bar",
+        bar => "baz",
+    },
+);
+
+check_req(
+    "http://www.example.com/?bar=baz&s2id=5&format=light&style=site",
+    undef, {
+        args => {
+            foo => 'bar',
+        },
+        keep_args => [ 'bar' ],
+        viewing_style => 1
+    },
+    { ssl => 0, host => "www.example.com", uri=>"/", },
+    {
+        foo => "bar",
+        bar => "baz",
+        s2id => 5,
+        format => "light",
+        style => "site",
+    },
+);
+
+check_req(
+    "http://www.example.com/?bar=baz&s2id=5&format=light&style=site",
+    undef, {
+        args => {
+            foo => 'bar',
+            s2id => undef,
+            bar => "kitten",
+        },
+        keep_args => [ 'bar' ],
+        viewing_style => 1
+    },
+    { ssl => 0, host => "www.example.com", uri=>"/", },
+    {
+        foo => "bar",
+        bar => "kitten",
+        format => "light",
+        style => "site",
+    },
+);
+
+check_req(
+    "http://www.example.com/?bar=baz&s2id=5&format=light&style=site&some=other&cruft=1",
+    undef, {
+        args => {
+            foo => 'bar',
+            bar => undef,
+            mew => undef,
+        },
+        keep_args => [ 'bar' ],
+    },
+    { ssl => 0, host => "www.example.com", uri=>"/", },
+    {
+        foo => "bar",
+    },
+);
+
+check_req(
+    "https://www.example.com/",
+    undef, {
+    },
+    { ssl => 1, host => "www.example.com", uri=>"/", },
+    {},
+);
+
+check_req(
+    "https://www.example.com/",
+    undef, {
+        ssl => 0,
+    },
+    { ssl => 0, host => "www.example.com", uri=>"/", },
+    {},
+);
+
+check_req(
+    "https://www.example.com/",
+    undef, {
+        ssl => 1,
+    },
+    { ssl => 1, host => "www.example.com", uri=>"/", },
+    {},
+);
+
+check_req(
+    "http://www.example.com/",
+    undef, {
+        ssl => 1,
+    },
+    { ssl => 1, host => "www.example.com", uri=>"/", },
+    {},
+);
+
+check_req(
+    "https://www.example.com/",
+    undef, {
+        host => "foo.example.com",
+    },
+    { ssl => 0, host => "foo.example.com", uri=>"/", },
+    {},
+);
+
+check_req(
+    "https://www.example.com/",
+    undef, {
+        host => "foo.example.com",
+        ssl => 1,
+    },
+    { ssl => 1, host => "foo.example.com", uri=>"/", },
+    {},
+);
+
+check_req(
+    "http://www.example.com/",
+    "/mmm_path", {
+    },
+    { ssl => 0, host => "www.example.com", uri=>"/mmm_path", },
+    {},
+);
+
+check_req(
+    "http://www.example.com/meow",
+    undef, {
+    },
+    { ssl => 0, host => "www.example.com", uri=>"/meow", },
+    {},
+);
+
+check_req(
+    "http://www.example.com/meow",
+    undef, {
+        fragment => "kitten",
+    },
+    { ssl => 0, host => "www.example.com", uri=>"/meow", fragment => "kitten" },
+    {},
+);
+
+sub check_req {
+    my ( $url, $path, $opts, $eopts, $expected ) = @_;
+
+    my $rq = HTTP::Request->new(GET => $url);
+    my ( $https, $host ) = $url =~ m!^(http(?:s)?)://(.+?)/!;
+    $LJ::IS_SSL = ( $https eq 'https' ) ? 1 : 0;
+    $rq->header("Host", $host);
+
+    DW::Request->reset;
+    my $r = DW::Request::Standard->new($rq);
+
+    my $nurl = LJ::create_url( $path, %$opts );
+
+    validate_req($nurl,$eopts,$expected);
+}
+
+sub validate_req {
+    my ( $url, $eopts, $expected ) = @_;
+
+    my ( $https, $host, $blah, $fragment, $blah2 ) = $url =~ m!^(http(?:s)?)://(.+?)/(.*?)((?:#.+?)?)((?:\?.+?)?)$!;
+    my $ssl = ( $https eq 'https' ) ? 1 : 0;
+    my $rq = HTTP::Request->new(GET => $url);
+
+    DW::Request->reset;
+    my $r = DW::Request::Standard->new($rq);
+
+    is( $r->uri, $eopts->{uri}, "uri mismatch" );
+    is( $host, $eopts->{host}, "host mismatch" );
+    is( $ssl, $eopts->{ssl}, "invalid ssl" );
+
+    if ( $fragment ) {
+        $fragment =~ s/^#//;
+    } else {
+        $fragment = undef;
+    }
+
+    is( $fragment, $eopts->{fragment}, "invalid fragment" );
+
+    my $fail = '';
+    my $args = $r->get_args;
+
+    foreach my $k ( keys %$args ) {
+        if ( $args->{$k} ne $expected->{$k} ) {
+            $fail .= "$k ( $args->{$k} != $expected->{$k} ), ";
+        }
+        delete $expected->{$k};
+    }
+
+    $fail .= " -- missing: " . join(",", keys %$expected) if ( %$expected );
+
+    ok( ! $fail, "args mismatch: $fail");
+}
\ No newline at end of file
--------------------------------------------------------------------------------