line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package BusyBird::StatusStorage::Memory; |
2
|
2
|
|
|
2
|
|
121148
|
use v5.8.0; |
|
2
|
|
|
|
|
7
|
|
|
2
|
|
|
|
|
94
|
|
3
|
2
|
|
|
2
|
|
11
|
use strict; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
75
|
|
4
|
2
|
|
|
2
|
|
10
|
use warnings; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
82
|
|
5
|
2
|
|
|
2
|
|
14
|
use parent ('BusyBird::StatusStorage'); |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
17
|
|
6
|
2
|
|
|
2
|
|
165
|
use BusyBird::Util qw(set_param sort_statuses); |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
168
|
|
7
|
2
|
|
|
2
|
|
13
|
use BusyBird::Log qw(bblog); |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
99
|
|
8
|
2
|
|
|
2
|
|
875
|
use BusyBird::StatusStorage::Common qw(contains ack_statuses get_unacked_counts); |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
192
|
|
9
|
2
|
|
|
2
|
|
14
|
use BusyBird::DateTime::Format; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
48
|
|
10
|
2
|
|
|
2
|
|
762
|
use Storable qw(dclone); |
|
2
|
|
|
|
|
3031
|
|
|
2
|
|
|
|
|
186
|
|
11
|
2
|
|
|
2
|
|
19
|
use Carp; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
134
|
|
12
|
2
|
|
|
2
|
|
13
|
use List::Util qw(min); |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
152
|
|
13
|
2
|
|
|
2
|
|
641
|
use JSON; |
|
2
|
|
|
|
|
9721
|
|
|
2
|
|
|
|
|
12
|
|
14
|
2
|
|
|
2
|
|
294
|
use Try::Tiny; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
555
|
|
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
sub new { |
17
|
3
|
|
|
3
|
1
|
1635
|
my ($class, %options) = @_; |
18
|
3
|
|
|
|
|
20
|
my $self = bless { |
19
|
|
|
|
|
|
|
timelines => {}, ## timelines should always be sorted. |
20
|
|
|
|
|
|
|
}, $class; |
21
|
3
|
|
|
|
|
28
|
$self->set_param(\%options, 'max_status_num', 2000); |
22
|
3
|
50
|
|
|
|
18
|
if($self->{max_status_num} <= 0) { |
23
|
0
|
|
|
|
|
0
|
croak "max_status_num option must be bigger than 0."; |
24
|
|
|
|
|
|
|
} |
25
|
3
|
|
|
|
|
16
|
return $self; |
26
|
|
|
|
|
|
|
} |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
sub _log { |
29
|
0
|
|
|
0
|
|
0
|
my ($self, $level, $msg) = @_; |
30
|
0
|
|
|
|
|
0
|
bblog($level, $msg); |
31
|
|
|
|
|
|
|
} |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
sub _index { |
34
|
1057
|
|
|
1057
|
|
1652
|
my ($self, $timeline, $id) = @_; |
35
|
1057
|
100
|
|
|
|
2772
|
return -1 if not defined($self->{timelines}{$timeline}); |
36
|
1012
|
|
|
|
|
1310
|
my $tl = $self->{timelines}{$timeline}; |
37
|
1012
|
|
|
|
|
2909
|
my @ret = grep { $tl->[$_]{id} eq $id } 0..$#$tl; |
|
25080
|
|
|
|
|
38863
|
|
38
|
1012
|
50
|
|
|
|
2935
|
confess "multiple IDs in timeline $timeline." if int(@ret) >= 2; |
39
|
1012
|
100
|
|
|
|
2688
|
return int(@ret) == 0 ? -1 : $ret[0]; |
40
|
|
|
|
|
|
|
} |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
sub _acked { |
43
|
4930
|
|
|
4930
|
|
4270
|
my ($self, $status) = @_; |
44
|
2
|
|
|
2
|
|
9
|
no autovivification; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
11
|
|
45
|
4930
|
|
|
|
|
17422
|
return $status->{busybird}{acked_at}; |
46
|
|
|
|
|
|
|
} |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
sub save { |
49
|
0
|
|
|
0
|
1
|
0
|
my ($self, $filepath) = @_; |
50
|
0
|
0
|
|
|
|
0
|
if(not defined($filepath)) { |
51
|
0
|
|
|
|
|
0
|
croak '$filepath is not specified.'; |
52
|
|
|
|
|
|
|
} |
53
|
0
|
|
|
|
|
0
|
my $file; |
54
|
0
|
0
|
|
|
|
0
|
if(!open $file, ">", $filepath) { |
55
|
0
|
|
|
|
|
0
|
$self->_log("error", "Cannot open $filepath to write."); |
56
|
0
|
|
|
|
|
0
|
return 0; |
57
|
|
|
|
|
|
|
} |
58
|
0
|
|
|
|
|
0
|
my $success; |
59
|
|
|
|
|
|
|
try { |
60
|
0
|
|
|
0
|
|
0
|
print $file encode_json($self->{timelines}); |
61
|
0
|
|
|
|
|
0
|
$success = 1; |
62
|
|
|
|
|
|
|
}catch { |
63
|
0
|
|
|
0
|
|
0
|
my $e = shift; |
64
|
0
|
|
|
|
|
0
|
$self->_log("error", "Error while saving: $e"); |
65
|
0
|
|
|
|
|
0
|
$success = 0; |
66
|
0
|
|
|
|
|
0
|
}; |
67
|
0
|
|
|
|
|
0
|
close $file; |
68
|
0
|
|
|
|
|
0
|
return $success; |
69
|
|
|
|
|
|
|
} |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
sub load { |
72
|
0
|
|
|
0
|
1
|
0
|
my ($self, $filepath) = @_; |
73
|
0
|
0
|
|
|
|
0
|
if(not defined($filepath)) { |
74
|
0
|
|
|
|
|
0
|
croak '$filepath is not specified.'; |
75
|
|
|
|
|
|
|
} |
76
|
0
|
|
|
|
|
0
|
my $file; |
77
|
0
|
0
|
|
|
|
0
|
if(!open $file, "<", $filepath) { |
78
|
0
|
|
|
|
|
0
|
$self->_log("notice", "Cannot open $filepath to read"); |
79
|
0
|
|
|
|
|
0
|
return 0; |
80
|
|
|
|
|
|
|
} |
81
|
0
|
|
|
|
|
0
|
my $success; |
82
|
|
|
|
|
|
|
try { |
83
|
0
|
|
|
0
|
|
0
|
my $text = do { local $/; <$file> }; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
84
|
0
|
|
|
|
|
0
|
$self->{timelines} = decode_json($text); |
85
|
0
|
|
|
|
|
0
|
$success = 1; |
86
|
|
|
|
|
|
|
}catch { |
87
|
0
|
|
|
0
|
|
0
|
my $e = shift; |
88
|
0
|
|
|
|
|
0
|
$self->_log("error", "Error while loading: $e"); |
89
|
0
|
|
|
|
|
0
|
$success = 0; |
90
|
0
|
|
|
|
|
0
|
}; |
91
|
0
|
|
|
|
|
0
|
close $file; |
92
|
0
|
|
|
|
|
0
|
return $success; |
93
|
|
|
|
|
|
|
} |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
sub _is_timestamp_format_ok { |
96
|
1799
|
|
|
1799
|
|
2483
|
my ($timestamp_str) = @_; |
97
|
1799
|
100
|
|
|
|
5029
|
return 1 if not defined $timestamp_str; |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
## It is very inefficient to parse $timestamp_str to check its |
100
|
|
|
|
|
|
|
## format, because creating a DateTime object takes long time. We |
101
|
|
|
|
|
|
|
## do it because BB::SS::Memory is just a reference |
102
|
|
|
|
|
|
|
## implementation. |
103
|
1318
|
|
|
|
|
3993
|
return defined(BusyBird::DateTime::Format->parse_datetime($timestamp_str)); |
104
|
|
|
|
|
|
|
} |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
sub put_statuses { |
107
|
121
|
|
|
121
|
1
|
24821
|
my ($self, %args) = @_; |
108
|
121
|
100
|
|
|
|
612
|
croak 'timeline arg is mandatory' if not defined $args{timeline}; |
109
|
120
|
|
|
|
|
266
|
my $timeline = $args{timeline}; |
110
|
120
|
100
|
100
|
|
|
1143
|
if(!defined($args{mode}) || |
|
|
|
66
|
|
|
|
|
|
|
|
66
|
|
|
|
|
111
|
|
|
|
|
|
|
($args{mode} ne 'insert' |
112
|
|
|
|
|
|
|
&& $args{mode} ne 'update' && $args{mode} ne 'upsert')) { |
113
|
1
|
|
|
|
|
117
|
croak 'mode arg must be insert/update/upsert'; |
114
|
|
|
|
|
|
|
} |
115
|
119
|
|
|
|
|
262
|
my $mode = $args{mode}; |
116
|
119
|
|
|
|
|
190
|
my $statuses; |
117
|
119
|
100
|
|
|
|
867
|
if(!defined($args{statuses})) { |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
118
|
1
|
|
|
|
|
121
|
croak 'statuses arg is mandatory'; |
119
|
|
|
|
|
|
|
}elsif(ref($args{statuses}) eq 'HASH') { |
120
|
28
|
|
|
|
|
70
|
$statuses = [ $args{statuses} ]; |
121
|
|
|
|
|
|
|
}elsif(ref($args{statuses}) eq 'ARRAY') { |
122
|
90
|
|
|
|
|
201
|
$statuses = $args{statuses}; |
123
|
|
|
|
|
|
|
}else { |
124
|
0
|
|
|
|
|
0
|
croak 'statuses arg must be STATUS/ARRAYREF_OF_STATUSES'; |
125
|
|
|
|
|
|
|
} |
126
|
118
|
|
|
|
|
386
|
foreach my $s (@$statuses) { |
127
|
2
|
|
|
2
|
|
1221
|
no autovivification; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
8
|
|
128
|
919
|
100
|
|
|
|
408648
|
croak "{id} field is mandatory in statuses" if not defined $s->{id}; |
129
|
904
|
100
|
100
|
|
|
5376
|
croak "{busybird} field must be a hash-ref if present" if defined($s->{busybird}) && ref($s->{busybird}) ne "HASH"; |
130
|
901
|
100
|
|
|
|
2098
|
croak "{created_at} field must be parsable by BusyBird::DateTime::Format" if !_is_timestamp_format_ok($s->{created_at}); |
131
|
898
|
|
|
|
|
889050
|
my $acked_at = $s->{busybird}{acked_at}; ## avoid autovivification |
132
|
898
|
100
|
|
|
|
2472
|
croak "{busybird}{acked_at} field must be parsable by BusyBird::DateTime::Format" if !_is_timestamp_format_ok($acked_at); |
133
|
|
|
|
|
|
|
} |
134
|
94
|
|
|
|
|
33960
|
my $put_count = 0; |
135
|
94
|
|
|
|
|
481
|
foreach my $status_index (reverse 0 .. $#$statuses) { |
136
|
880
|
|
|
|
|
1252
|
my $s = $statuses->[$status_index]; |
137
|
880
|
|
|
|
|
2359
|
my $tl_index = $self->_index($timeline, $s->{id}); |
138
|
880
|
|
|
|
|
1268
|
my $existent = ($tl_index >= 0); |
139
|
880
|
100
|
100
|
|
|
5108
|
next if ($mode eq 'insert' && $existent) || ($mode eq 'update' && !$existent); |
|
|
|
100
|
|
|
|
|
|
|
|
66
|
|
|
|
|
140
|
869
|
|
|
|
|
1007
|
my $is_insert = ($mode eq 'insert'); |
141
|
869
|
100
|
|
|
|
1495
|
if($mode eq 'upsert') { |
142
|
24
|
|
|
|
|
24
|
$is_insert = (!$existent); |
143
|
|
|
|
|
|
|
} |
144
|
869
|
100
|
|
|
|
1268
|
if($is_insert) { |
145
|
548
|
|
|
|
|
451
|
unshift(@{$self->{timelines}{$timeline}}, dclone($s)); |
|
548
|
|
|
|
|
9546
|
|
146
|
|
|
|
|
|
|
}else { |
147
|
|
|
|
|
|
|
## update |
148
|
321
|
|
|
|
|
7064
|
$self->{timelines}{$timeline}[$tl_index] = dclone($s); |
149
|
|
|
|
|
|
|
} |
150
|
869
|
|
|
|
|
2187
|
$put_count++; |
151
|
|
|
|
|
|
|
} |
152
|
94
|
100
|
|
|
|
448
|
if($put_count > 0) { |
153
|
90
|
|
|
|
|
682
|
$self->{timelines}{$timeline} = sort_statuses($self->{timelines}{$timeline}); |
154
|
90
|
100
|
|
|
|
322
|
if(int(@{$self->{timelines}{$timeline}}) > $self->{max_status_num}) { |
|
90
|
|
|
|
|
722
|
|
155
|
3
|
|
|
|
|
6
|
splice(@{$self->{timelines}{$timeline}}, -(int(@{$self->{timelines}{$timeline}}) - $self->{max_status_num})); |
|
3
|
|
|
|
|
11
|
|
|
3
|
|
|
|
|
27
|
|
156
|
|
|
|
|
|
|
} |
157
|
|
|
|
|
|
|
} |
158
|
94
|
50
|
|
|
|
454
|
if($args{callback}) { |
159
|
94
|
|
|
|
|
309
|
@_ = (undef, $put_count); |
160
|
94
|
|
|
|
|
800
|
goto $args{callback}; |
161
|
|
|
|
|
|
|
} |
162
|
|
|
|
|
|
|
} |
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
sub delete_statuses { |
165
|
58
|
|
|
58
|
1
|
14133
|
my ($self, %args) = @_; |
166
|
58
|
100
|
|
|
|
488
|
croak 'timeline arg is mandatory' if not defined $args{timeline}; |
167
|
57
|
100
|
|
|
|
339
|
croak 'ids arg is mandatory' if not exists $args{ids}; |
168
|
56
|
|
|
|
|
101
|
my $timeline = $args{timeline}; |
169
|
56
|
|
|
|
|
95
|
my $ids = $args{ids}; |
170
|
56
|
100
|
|
|
|
212
|
if(defined($ids)) { |
171
|
7
|
100
|
|
|
|
35
|
if(!ref($ids)) { |
|
|
50
|
|
|
|
|
|
172
|
2
|
|
|
|
|
6
|
$ids = [$ids]; |
173
|
|
|
|
|
|
|
}elsif(ref($ids) eq 'ARRAY') { |
174
|
5
|
100
|
|
|
|
14
|
croak "ids arg array must not contain undef" if grep { !defined($_) } @$ids; |
|
14
|
|
|
|
|
153
|
|
175
|
|
|
|
|
|
|
}else { |
176
|
0
|
|
|
|
|
0
|
croak "ids must be undef/ID/ARRAYREF_OF_IDS"; |
177
|
|
|
|
|
|
|
} |
178
|
|
|
|
|
|
|
} |
179
|
55
|
100
|
|
|
|
258
|
if(!$self->{timelines}{$timeline}) { |
180
|
14
|
50
|
|
|
|
50
|
if($args{callback}) { |
181
|
14
|
|
|
|
|
40
|
@_ = (undef, 0); |
182
|
14
|
|
|
|
|
63
|
goto $args{callback}; |
183
|
|
|
|
|
|
|
} |
184
|
0
|
|
|
|
|
0
|
return; |
185
|
|
|
|
|
|
|
} |
186
|
41
|
|
|
|
|
74
|
my $delete_num = 0; |
187
|
41
|
100
|
|
|
|
122
|
if(defined($ids)) { |
188
|
5
|
|
|
|
|
13
|
foreach my $id (@$ids) { |
189
|
8
|
|
|
|
|
26
|
my $tl_index = $self->_index($timeline, $id); |
190
|
8
|
100
|
|
|
|
27
|
last if $tl_index < 0; |
191
|
7
|
|
|
|
|
7
|
splice(@{$self->{timelines}{$timeline}}, $tl_index, 1); |
|
7
|
|
|
|
|
22
|
|
192
|
7
|
|
|
|
|
28
|
$delete_num++; |
193
|
|
|
|
|
|
|
} |
194
|
|
|
|
|
|
|
}else { |
195
|
36
|
50
|
|
|
|
144
|
if(defined($self->{timelines}{$timeline})) { |
196
|
36
|
|
|
|
|
57
|
$delete_num = @{$self->{timelines}{$timeline}}; |
|
36
|
|
|
|
|
99
|
|
197
|
36
|
|
|
|
|
543
|
delete $self->{timelines}{$timeline}; |
198
|
|
|
|
|
|
|
} |
199
|
|
|
|
|
|
|
} |
200
|
41
|
50
|
|
|
|
164
|
if($args{callback}) { |
201
|
41
|
|
|
|
|
126
|
@_ = (undef, $delete_num); |
202
|
41
|
|
|
|
|
197
|
goto $args{callback}; |
203
|
|
|
|
|
|
|
} |
204
|
|
|
|
|
|
|
} |
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
sub get_statuses { |
207
|
538
|
|
|
538
|
1
|
27190
|
my ($self, %args) = @_; |
208
|
538
|
100
|
|
|
|
2102
|
croak 'timeline arg is mandatory' if not defined $args{timeline}; |
209
|
537
|
100
|
|
|
|
1937
|
croak 'callback arg is mandatory' if not defined $args{callback}; |
210
|
536
|
|
|
|
|
968
|
my $timeline = $args{timeline}; |
211
|
536
|
100
|
|
|
|
2207
|
if(!$self->{timelines}{$timeline}) { |
212
|
68
|
|
|
|
|
160
|
@_ = (undef, []); |
213
|
68
|
|
|
|
|
286
|
goto $args{callback}; |
214
|
|
|
|
|
|
|
} |
215
|
468
|
|
100
|
|
|
1638
|
my $ack_state = $args{ack_state} || 'any'; |
216
|
468
|
|
|
|
|
741
|
my $max_id = $args{max_id}; |
217
|
468
|
50
|
|
|
|
1336
|
my $count = defined($args{count}) ? $args{count} : 20; |
218
|
|
|
|
|
|
|
my $ack_test = $ack_state eq 'unacked' ? sub { |
219
|
2866
|
|
|
2866
|
|
3636
|
!$self->_acked(shift); |
220
|
|
|
|
|
|
|
} : $ack_state eq 'acked' ? sub { |
221
|
2064
|
|
|
2064
|
|
2694
|
$self->_acked(shift); |
222
|
468
|
100
|
|
3121
|
|
2753
|
} : sub { 1 }; |
|
3121
|
100
|
|
|
|
8611
|
|
223
|
468
|
|
|
|
|
895
|
my $start_index; |
224
|
468
|
100
|
|
|
|
1170
|
if(defined($max_id)) { |
225
|
169
|
|
|
|
|
526
|
my $tl_index = $self->_index($timeline, $max_id); |
226
|
169
|
100
|
|
|
|
384
|
if($tl_index < 0) { |
227
|
23
|
|
|
|
|
63
|
@_ = (undef, []); |
228
|
23
|
|
|
|
|
122
|
goto $args{callback}; |
229
|
|
|
|
|
|
|
} |
230
|
146
|
|
|
|
|
290
|
my $s = $self->{timelines}{$timeline}[$tl_index]; |
231
|
146
|
100
|
|
|
|
401
|
if(!$ack_test->($s)) { |
232
|
40
|
|
|
|
|
80
|
@_ = (undef, []); |
233
|
40
|
|
|
|
|
222
|
goto $args{callback}; |
234
|
|
|
|
|
|
|
} |
235
|
106
|
|
|
|
|
178
|
$start_index = $tl_index; |
236
|
|
|
|
|
|
|
} |
237
|
|
|
|
|
|
|
my @indice = grep { |
238
|
7905
|
100
|
100
|
|
|
12648
|
if(!$ack_test->($self->{timelines}{$timeline}[$_])) { |
|
405
|
100
|
|
|
|
1773
|
|
239
|
2283
|
|
|
|
|
2991
|
0; |
240
|
|
|
|
|
|
|
}elsif(defined($start_index) && $_ < $start_index) { |
241
|
726
|
|
|
|
|
852
|
0; |
242
|
|
|
|
|
|
|
}else { |
243
|
4896
|
|
|
|
|
6462
|
1; |
244
|
|
|
|
|
|
|
} |
245
|
405
|
|
|
|
|
823
|
} 0 .. $#{$self->{timelines}{$timeline}}; |
246
|
405
|
100
|
|
|
|
1609
|
$count = int(@indice) if $count eq 'all'; |
247
|
405
|
|
|
|
|
1639
|
$count = min($count, int(@indice)); |
248
|
4382
|
|
|
|
|
57493
|
my $result_statuses = $count <= 0 ? [] : [ map { |
249
|
405
|
100
|
|
|
|
1786
|
dclone($self->{timelines}{$timeline}[$_]) |
250
|
|
|
|
|
|
|
} @indice[0 .. ($count-1)] ]; |
251
|
|
|
|
|
|
|
|
252
|
405
|
|
|
|
|
1333
|
@_ = (undef, $result_statuses); |
253
|
405
|
|
|
|
|
3435
|
goto $args{callback}; |
254
|
|
|
|
|
|
|
} |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
1; |
257
|
|
|
|
|
|
|
|
258
|
|
|
|
|
|
|
__END__ |