viewvc.cgi/VRac/Session.pm

package Session;

# Dobrica Pavlinusic, <dpavlin@rot13.org> 08/05/07 14:27:15 CEST

use strict;
use warnings;

use Carp qw/confess croak/;
use Data::Dump qw/dump/;
use File::Slurp;
use POSIX qw/strftime/;

use base qw/Class::Accessor/;
__PACKAGE__->mk_accessors(qw(session_uuid));


=head1 NAME

Session - save or load emulator interactive session

=head1 DESCRIPTION

Sessions are simple perl programs using one function C<event>

  event( $ticks_wait, 'name', $hash );

Using this, you can refactor your sessions or use perl constructs around
them.

=head1 FUNCTIONS

=head2 record_session

  $self->record_session( 'name', $value );

=cut

my $path = 'session.pl';

my $last_tick = 0;

my $t = 0;
my @timeline;
my $s;

sub record_session {
        my $self = shift;
        my $name = shift || confess "need name";
        my $value = shift || confess "need value";

        if ( @timeline ) {
                warn "INFO: Aborting recorderd session\n";
                @timeline = ();
                $t = 0;
                $s = {};
        }

        my $t = $self->app->ticks;
        my $dt = $t - $last_tick;
        $last_tick = $t;

        if ( ! $self->session_uuid ) {
                my $uuid = strftime('%Y-%m-%d %H:%M:%S',localtime);
                $self->append_to_file($path, "# $uuid\n");
                $self->session_uuid( $uuid );
        }

        $self->append_to_file($path, 'event(', dump( $dt, $name, $value ),");\n");

}

sub event {
        my $dt = shift || croak 'expected dt';
        my $name = shift || croak 'expected name';
        my $value = shift || croak 'expected value';

        $t += $dt;
        push @timeline, $t;
        $s->{$t}->{$name} = $value;

        warn "## created event($dt,$name,",dump($value),")\n";
}

=head2 load_session

  $self->load_session( '/path/to/session.pl' );

=cut

sub load_session {
        my $self = shift;
        my $path = shift || confess "no path?";

        if ( ! -r $path ) {
                warn "WARNING: can't open session $path: $!\n";
                return;
        }

        eval read_file( $path );
        warn "session = ",dump( $s );

        my ( $from, $to ) = @timeline[0,-1];
        printf "loaded session %.2f-%.2fs with %d events\n", $from / 1000, $to / 1000, $#timeline + 1;
}

=head2 session_event

  my $v = $self->session_event('key_pressed');

=cut

sub session_event {
        my $self = shift;

        return unless @timeline;

        my $name = shift || confess "no name?";

        my $t = $self->app->ticks;

        # do we have events to trigger?
        return if ( $t < $timeline[0] );

        my $e_t = $timeline[0];

        # do we have next event and should we take it?
        if ( $#timeline > 0 && $t > $timeline[1] ) {
                shift @timeline;
                $e_t = $timeline[0];
                warn "session_event $e_t $name ",dump( $s->{$e_t}->{$name} )," left ", $#timeline+1, " events\n";
        }

        return $s->{$e_t}->{$name};
}

=head1 SEE ALSO

L<VRac>

=cut

1;
1	dpavlin	145	package Session;
2
3			# Dobrica Pavlinusic, <dpavlin@rot13.org> 08/05/07 14:27:15 CEST
4
5			use strict;
6			use warnings;
7
8	dpavlin	159	use Carp qw/confess croak/;
9	dpavlin	145	use Data::Dump qw/dump/;
10			use File::Slurp;
11	dpavlin	159	use POSIX qw/strftime/;
12	dpavlin	145
13			use base qw/Class::Accessor/;
14	dpavlin	159	__PACKAGE__->mk_accessors(qw(session_uuid));
15	dpavlin	145
16
17			=head1 NAME
18
19			Session - save or load emulator interactive session
20
21	dpavlin	159	=head1 DESCRIPTION
22	dpavlin	145
23	dpavlin	159	Sessions are simple perl programs using one function C<event>
24
25			event( $ticks_wait, 'name', $hash );
26
27			Using this, you can refactor your sessions or use perl constructs around
28			them.
29
30	dpavlin	145	=head1 FUNCTIONS
31
32			=head2 record_session
33
34	dpavlin	150	$self->record_session( 'name', $value );
35	dpavlin	145
36			=cut
37
38	dpavlin	159	my $path = 'session.pl';
39
40			my $last_tick = 0;
41
42			my $t = 0;
43			my @timeline;
44			my $s;
45
46	dpavlin	145	sub record_session {
47			my $self = shift;
48	dpavlin	150	my $name = shift \|\| confess "need name";
49	dpavlin	159	my $value = shift \|\| confess "need value";
50	dpavlin	145
51	dpavlin	159	if ( @timeline ) {
52			warn "INFO: Aborting recorderd session\n";
53			@timeline = ();
54			$t = 0;
55			$s = {};
56			}
57
58	dpavlin	145	my $t = $self->app->ticks;
59	dpavlin	159	my $dt = $t - $last_tick;
60			$last_tick = $t;
61	dpavlin	145
62	dpavlin	159	if ( ! $self->session_uuid ) {
63			my $uuid = strftime('%Y-%m-%d %H:%M:%S',localtime);
64			$self->append_to_file($path, "# $uuid\n");
65			$self->session_uuid( $uuid );
66			}
67	dpavlin	145
68	dpavlin	159	$self->append_to_file($path, 'event(', dump( $dt, $name, $value ),");\n");
69
70	dpavlin	145	}
71
72	dpavlin	159	sub event {
73			my $dt = shift \|\| croak 'expected dt';
74			my $name = shift \|\| croak 'expected name';
75			my $value = shift \|\| croak 'expected value';
76
77			$t += $dt;
78			push @timeline, $t;
79			$s->{$t}->{$name} = $value;
80
81			warn "## created event($dt,$name,",dump($value),")\n";
82			}
83
84	dpavlin	145	=head2 load_session
85
86			$self->load_session( '/path/to/session.pl' );
87
88			=cut
89
90			sub load_session {
91			my $self = shift;
92			my $path = shift \|\| confess "no path?";
93
94	dpavlin	150	if ( ! -r $path ) {
95			warn "WARNING: can't open session $path: $!\n";
96			return;
97			}
98
99	dpavlin	145	eval read_file( $path );
100	dpavlin	150	warn "session = ",dump( $s );
101	dpavlin	145
102			my ( $from, $to ) = @timeline[0,-1];
103			printf "loaded session %.2f-%.2fs with %d events\n", $from / 1000, $to / 1000, $#timeline + 1;
104			}
105
106	dpavlin	150	=head2 session_event
107
108			my $v = $self->session_event('key_pressed');
109
110			=cut
111
112			sub session_event {
113			my $self = shift;
114
115			return unless @timeline;
116
117			my $name = shift \|\| confess "no name?";
118
119			my $t = $self->app->ticks;
120
121			# do we have events to trigger?
122			return if ( $t < $timeline[0] );
123
124			my $e_t = $timeline[0];
125
126			# do we have next event and should we take it?
127			if ( $#timeline > 0 && $t > $timeline[1] ) {
128			shift @timeline;
129			$e_t = $timeline[0];
130			warn "session_event $e_t $name ",dump( $s->{$e_t}->{$name} )," left ", $#timeline+1, " events\n";
131			}
132
133			return $s->{$e_t}->{$name};
134			}
135
136	dpavlin	145	=head1 SEE ALSO
137
138			L<VRac>
139
140			=cut
141
142			1;