1package HTTP::Session;
2use strict;
3use warnings;
4use base qw/Class::Accessor::Fast/;
5use 5.00800;
6our $VERSION = '0.49';
7use Carp ();
8use Scalar::Util ();
9use Module::Runtime ();
10
11__PACKAGE__->mk_ro_accessors(qw/store request sid_length save_modified_session_only/);
12__PACKAGE__->mk_accessors(qw/session_id _data is_changed is_fresh state/);
13
14sub new {
15    my $class = shift;
16    my %args = ref($_[0]) ? %{$_[0]} : @_;
17    # check required parameters
18    for my $key (qw/store state request/) {
19        Carp::croak "missing parameter $key" unless $args{$key};
20    }
21    # set default values
22    $args{_data} ||= {};
23    $args{save_modified_session_only} ||= 0;
24    $args{is_changed} ||= 0;
25    $args{is_fresh}   ||= 0;
26    $args{sid_length} ||= 32;
27    $args{id}         ||= 'HTTP::Session::ID::SHA1';
28    my $self = bless {%args}, $class;
29    $self->_load_session();
30    Carp::croak "[BUG] we have bug" unless $self->{request};
31    $self;
32}
33
34sub _load_session {
35    my $self = shift;
36
37    my $session_id = $self->state->get_session_id($self->request);
38    if ( $session_id ) {
39        my $data = $self->store->select($session_id);
40        if ($data) {
41            $self->session_id( $session_id );
42            $self->_data($data);
43        } else {
44            if ($self->state->permissive) {
45                $self->session_id( $session_id );
46                $self->is_fresh(1);
47            } else {
48                # session was expired? or session fixation?
49                # regen session id.
50                $self->session_id( $self->_generate_session_id() );
51                $self->is_fresh(1);
52            }
53        }
54    } else {
55        # no sid; generate it
56        $self->session_id( $self->_generate_session_id() );
57        $self->is_fresh(1);
58    }
59}
60
61sub _generate_session_id {
62    my $self = shift;
63    Module::Runtime::require_module($self->{id}) or die $@;
64    $self->{id}->generate_id($self->sid_length);
65}
66
67sub response_filter {
68    my ($self, $response) = @_;
69    Carp::croak "missing response" unless ref $response;
70
71    $self->state->response_filter($self->session_id, $response);
72}
73
74sub finalize {
75    my ($self, ) = @_;
76
77    if ($self->is_fresh) {
78        if ($self->is_changed || !$self->save_modified_session_only) {
79            $self->store->insert( $self->session_id, $self->_data );
80        }
81    } else {
82        if ($self->is_changed) {
83            $self->store->update( $self->session_id, $self->_data );
84        }
85    }
86
87    delete $self->{$_} for keys %$self;
88    bless $self, 'HTTP::Session::Finalized';
89}
90
91sub DESTROY {
92    my $self = shift;
93
94    if ($self->{store}) {
95        $self->finalize();
96    } else {
97        # this case happen at global destruction?
98        Carp::carp "you should call HTTP::Session->finalize method manually";
99    }
100}
101
102sub keys {
103    my $self = shift;
104    return keys %{ $self->_data };
105}
106
107sub get {
108    my ($self, $key) = @_;
109    $self->_data->{$key};
110}
111
112sub set {
113    my ($self, $key, $val) = @_;
114    $self->is_changed(1);
115    $self->_data->{$key} = $val;
116}
117
118sub remove {
119    my ( $self, $key ) = @_;
120    $self->is_changed(1);
121    delete $self->_data->{$key};
122}
123
124sub as_hashref {
125    my $self = shift;
126    return { %{ $self->_data } }; # shallow copy
127}
128
129sub expire {
130    my $self = shift;
131    $self->store->delete($self->session_id);
132
133    # XXX tricky bit to unlock
134    delete $self->{$_} for qw(is_fresh is_changed);
135    $self->DESTROY;
136
137    # rebless to null class
138    bless $self, 'HTTP::Session::Expired';
139}
140
141sub regenerate_session_id {
142    my ($self, $delete_old) = @_;
143    $self->_data( { %{ $self->_data } } );
144
145    if ($delete_old) {
146        my $oldsid = $self->session_id;
147        $self->store->delete($oldsid);
148    }
149    my $session_id = $self->_generate_session_id();
150    $self->session_id( $session_id );
151    $self->is_fresh(1);
152}
153
154BEGIN {
155    no strict 'refs';
156    for my $meth (qw/redirect_filter header_filter html_filter/) {
157        *{__PACKAGE__ . '::' . $meth} = sub {
158            my ($self, $stuff) = @_;
159            if ($self->state->can($meth)) {
160                $self->state->$meth($self->session_id, $stuff);
161            } else {
162                $stuff;
163            }
164        };
165    }
166}
167
168package HTTP::Session::Finalized;
169sub is_fresh { 0 }
170sub AUTOLOAD { }
171
172package HTTP::Session::Expired;
173sub is_fresh { 0 }
174sub AUTOLOAD { }
175
1761;
177__END__
178
179=encoding utf8
180
181=head1 NAME
182
183HTTP::Session - simple session
184
185=head1 SYNOPSIS
186
187    use HTTP::Session;
188
189    my $session = HTTP::Session->new(
190        store   => HTTP::Session::Store::Memcached->new(
191            memd => Cache::Memcached->new({
192                servers => ['127.0.0.1:11211'],
193            }),
194        ),
195        state   => HTTP::Session::State::Cookie->new(
196            name => 'foo_sid'
197        ),
198        request => $c->req,
199    );
200
201=head1 DESCRIPTION
202
203Yet another session manager.
204
205easy to integrate with L<PSGI> =)
206
207=head1 METHODS
208
209=over 4
210
211=item my $session = HTTP::Session->new(store => $store, state => $state, request => $req)
212
213This method creates new instance of HTTP::Session.
214
215C<store> is instance of HTTP::Session::Store::*.
216
217C<state> is instance of HTTP::Session::State::*.
218
219C<request> is duck typed object.C<request> object should have C<header>, C<address>, C<param>.
220You can use PSGI's $env instead.
221
222=item $session->html_filter($html)
223
224filtering HTML
225
226=item $session->redirect_filter($url)
227
228filtering redirect URL
229
230=item $session->header_filter($res)
231
232filtering header
233
234=item $session->response_filter($res)
235
236filtering response. this method runs html_filter, redirect_filter and header_filter.
237
238$res should be PSGI's response array, instance of L<HTTP::Response>, or L<HTTP::Engine::Response>.
239
240=item $session->keys()
241
242keys of session.
243
244=item $session->get(key)
245
246get session item
247
248=item $session->set(key, val)
249
250set session item
251
252=item $session->remove(key)
253
254remove item.
255
256=item $session->as_hashref()
257
258session as hashref.
259
260=item $session->expire()
261
262expire the session
263
264=item $session->regenerate_session_id([$delete_old])
265
266regenerate session id.remove old one when $delete_old is true value.
267
268=item $session->finalize()
269
270commit the session data.
271
272=back
273
274=head1 CLEANUP SESSION
275
276Some storage doesn't care the old session data.Please call $store->cleanup( $min ); manually.
277
278=head1 AUTHOR
279
280Tokuhiro Matsuno E<lt>tokuhirom AAJKLFJEF GMAIL COME<gt>
281
282=head1 THANKS TO
283
284    kazuhooku
285    amachang
286    walf443
287    yappo
288    nekokak
289
290=head1 REPOSITORY
291
292I use github.
293repo url is here L<http://github.com/tokuhirom/http-session/tree/master>
294
295=head1 SEE ALSO
296
297L<Catalyst::Plugin::Session>, L<Sledge::Session>
298
299=head1 LICENSE
300
301This library is free software; you can redistribute it and/or modify
302it under the same terms as Perl itself.
303
304=cut
305