1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
|
package FakeFetch;
# networkless URIFetch::fetch()
# SYNOPSIS
#
use strict;
use warnings;
use vars qw/@EXPORT @ISA/;
@ISA = qw/Exporter/;
@EXPORT = qw(
uri_scenario
resetf
addf_dead_h
addf_404_h
addf_500_h
addf_dead_uri
addf_404_uri
addf_500_uri
addf_dead_ure
addf_404_ure
addf_500_ure
addf_h
addf_uri
addf_ure
);
# copied from URIFetch::fetch
my @useful_headers = qw(last-modified etag content-type x-yadis-location x-xrds-location);
# list of { ure => regexp, final_uri => ..., code => 200, content => , [<hdr> => <string>,...]}
our @fetchables = ();
sub resetf { @fetchables = (); }
sub uri_scenario {
my ($code) = @_;
local @fetchables = ();
$code->();
}
my @respond_dead = (code => '000');
my @respond_404 = (code => '404', content =>'Not Found -- random text');
my @respond_500 = (code => '500', content =>'Internal Error -- random text');
sub addf_dead_h { addf_h(@respond_dead, @_); }
sub addf_404_h { addf_h(@respond_404, @_); }
sub addf_500_h { addf_h(@respond_500, @_); }
sub addf_dead_uri { addf_uri(@respond_dead, @_); }
sub addf_404_uri { addf_uri(@respond_404, @_); }
sub addf_500_uri { addf_uri(@respond_500, @_); }
sub addf_dead_ure { addf_ure(@respond_dead, @_); }
sub addf_404_ure { addf_ure(@respond_404, @_); }
sub addf_500_ure { addf_ure(@respond_500, @_); }
sub addf_h {
my (%bad) = @_;
my %h = map {exists $bad{$_} ? ($_,delete $bad{$_}) : ()}
@useful_headers, qw(uri ure final_uri code content);
die 'unexpected params: '.join(',',keys %bad) if keys %bad;
if ($h{uri}) {
die 'uri and ure' if $h{ure};
$h{ure} = qr/^$h{uri}$/;
$h{final_uri} = $h{uri} unless $h{final_uri};
}
elsif (!$h{ure}) {
die 'need uri or ure';
}
$h{code} = 200 unless $h{code};
die 'weird code' unless $h{code} =~ m/^[02-5]\d\d$/;
unless ($h{content}) {
$h{content} = '';
}
unshift @fetchables, \%h;
}
sub addf_uri {
my $uri = shift;
addf_h(uri => $uri, @_);
}
sub addf_ure {
my $ure = shift;
addf_h(ure => $ure, @_);
}
our %fake_cache = ();
sub _my_fetch {
my ($class, $uri, $consumer, $content_hook, $prefix) = @_;
$prefix ||= '';
# keep behavior of actual URI::Fetch->fetch()
if ($uri eq 'x-xrds-location') {
Carp::confess("Buh?");
}
my $cache_key = "URIFetch:${prefix}:${uri}";
if (my $blob = $fake_cache{$cache_key}) {
my $ref = Storable::thaw($blob);
return Net::OpenID::URIFetch::Response->new(
status => 200,
content => $ref->{Content},
headers => $ref->{Headers},
final_uri => $ref->{FinalURI},
);
}
# pretend to get $uri
# $req = HTTP::Request->new(GET => $uri);
# $res = $ua->request($req);
# $content = $res->content;
# $final_uri = $res->request->uri->as_string();
foreach my $f (@fetchables) {
next if $uri !~ $f->{ure};
return if $f->{code} eq '000';
my $content = $f->{content};
if ($content_hook) {
$content_hook->(\$content);
}
my $headers = {};
foreach my $k (@useful_headers) {
$headers->{$k} = $f->{$k};
}
my $final_uri = $f->{final_uri} || $uri;
if ($f->{code} == 200) {
my $cache_data = {
Headers => $headers,
Content => $content,
FinalURI => $final_uri,
CacheTime => time(),
};
my $cache_blob = Storable::freeze($cache_data);
my $final_cache_key = "URIFetch:${prefix}:${final_uri}";
$fake_cache{$final_cache_key} = $cache_blob;
$fake_cache{$cache_key} = $cache_blob;
}
return Net::OpenID::URIFetch::Response->new
(
status => $f->{code},
final_uri => $final_uri,
content => $content,
headers => $headers,
);
}
diag("unexpected URI: $uri")
}
no warnings;
*Net::OpenID::URIFetch::fetch = \&_my_fetch;
1;
|
