| line | stmt | bran | cond | sub | pod | time | code | 
| 1 |  |  |  |  |  |  | package BusyBird::Util; | 
| 2 | 17 |  |  | 17 |  | 222282 | use strict; | 
|  | 17 |  |  |  |  | 26 |  | 
|  | 17 |  |  |  |  | 625 |  | 
| 3 | 17 |  |  | 17 |  | 71 | use warnings; | 
|  | 17 |  |  |  |  | 21 |  | 
|  | 17 |  |  |  |  | 419 |  | 
| 4 | 17 |  |  | 17 |  | 72 | use Scalar::Util qw(blessed weaken); | 
|  | 17 |  |  |  |  | 20 |  | 
|  | 17 |  |  |  |  | 1266 |  | 
| 5 | 17 |  |  | 17 |  | 73 | use Carp; | 
|  | 17 |  |  |  |  | 22 |  | 
|  | 17 |  |  |  |  | 864 |  | 
| 6 | 17 |  |  | 17 |  | 71 | use Exporter qw(import); | 
|  | 17 |  |  |  |  | 57 |  | 
|  | 17 |  |  |  |  | 384 |  | 
| 7 | 17 |  |  | 17 |  | 4974 | use BusyBird::DateTime::Format; | 
|  | 17 |  |  |  |  | 1272308 |  | 
|  | 17 |  |  |  |  | 531 |  | 
| 8 | 17 |  |  | 17 |  | 6083 | use BusyBird::Log qw(bblog); | 
|  | 17 |  |  |  |  | 26 |  | 
|  | 17 |  |  |  |  | 885 |  | 
| 9 | 17 |  |  | 17 |  | 5830 | use BusyBird::SafeData qw(safed); | 
|  | 17 |  |  |  |  | 35 |  | 
|  | 17 |  |  |  |  | 844 |  | 
| 10 | 17 |  |  | 17 |  | 90 | use DateTime; | 
|  | 17 |  |  |  |  | 21 |  | 
|  | 17 |  |  |  |  | 293 |  | 
| 11 | 17 |  |  | 17 |  | 165 | use 5.10.0; | 
|  | 17 |  |  |  |  | 45 |  | 
|  | 17 |  |  |  |  | 639 |  | 
| 12 | 17 |  |  | 17 |  | 8705 | use Future::Q 0.040; | 
|  | 17 |  |  |  |  | 193933 |  | 
|  | 17 |  |  |  |  | 468 |  | 
| 13 | 17 |  |  | 17 |  | 8840 | use File::HomeDir; | 
|  | 17 |  |  |  |  | 77955 |  | 
|  | 17 |  |  |  |  | 1036 |  | 
| 14 | 17 |  |  | 17 |  | 101 | use File::Spec; | 
|  | 17 |  |  |  |  | 23 |  | 
|  | 17 |  |  |  |  | 2128 |  | 
| 15 |  |  |  |  |  |  |  | 
| 16 |  |  |  |  |  |  | our @EXPORT_OK = | 
| 17 |  |  |  |  |  |  | qw(set_param expand_param config_directory config_file_path sort_statuses | 
| 18 |  |  |  |  |  |  | split_with_entities future_of make_tracking vivifiable_as); | 
| 19 |  |  |  |  |  |  | our @CARP_NOT = qw(Future::Q); | 
| 20 |  |  |  |  |  |  |  | 
| 21 |  |  |  |  |  |  | sub set_param { | 
| 22 | 1616 |  |  | 1616 | 0 | 46081 | my ($hashref, $params_ref, $key, $default, $is_mandatory) = @_; | 
| 23 | 1616 | 50 | 66 |  |  | 5889 | if($is_mandatory && !defined($params_ref->{$key})) { | 
| 24 | 0 |  |  |  |  | 0 | my $classname = blessed $hashref; | 
| 25 | 0 |  |  |  |  | 0 | croak "ERROR: set_param in $classname: Parameter for '$key' is mandatory, but not supplied."; | 
| 26 |  |  |  |  |  |  | } | 
| 27 | 1616 | 100 |  |  |  | 5331 | $hashref->{$key} = (defined($params_ref->{$key}) ? $params_ref->{$key} : $default); | 
| 28 |  |  |  |  |  |  | } | 
| 29 |  |  |  |  |  |  |  | 
| 30 |  |  |  |  |  |  | sub export_ok_all_tags { | 
| 31 | 17 |  |  | 17 |  | 78 | no strict "refs"; | 
|  | 17 |  |  |  |  | 25 |  | 
|  | 17 |  |  |  |  | 6735 |  | 
| 32 | 8 |  |  | 8 | 0 | 45 | my ($caller_package) = caller; | 
| 33 | 8 |  |  |  |  | 21 | my $export_ok = \@{"${caller_package}::EXPORT_OK"}; | 
|  | 8 |  |  |  |  | 60 |  | 
| 34 | 8 |  |  |  |  | 17 | my $export_tags = \%{"${caller_package}::EXPORT_TAGS"}; | 
|  | 8 |  |  |  |  | 38 |  | 
| 35 | 8 |  |  |  |  | 29 | my @all = @$export_ok; | 
| 36 | 8 |  |  |  |  | 44 | foreach my $tag (keys %$export_tags) { | 
| 37 | 16 |  |  |  |  | 32 | my $exported = $export_tags->{$tag}; | 
| 38 | 16 |  |  |  |  | 37 | push(@all, @$exported); | 
| 39 | 16 |  |  |  |  | 44 | push(@$export_ok, @$exported); | 
| 40 |  |  |  |  |  |  | } | 
| 41 | 8 |  |  |  |  | 38 | $export_tags->{all} = \@all; | 
| 42 |  |  |  |  |  |  | } | 
| 43 |  |  |  |  |  |  |  | 
| 44 |  |  |  |  |  |  | sub expand_param { | 
| 45 | 0 |  |  | 0 | 0 | 0 | my ($param, @names) = @_; | 
| 46 | 0 |  |  |  |  | 0 | my $refparam = ref($param); | 
| 47 | 0 |  |  |  |  | 0 | my @result = (); | 
| 48 | 0 | 0 |  |  |  | 0 | if($refparam eq 'ARRAY') { | 
|  |  | 0 |  |  |  |  |  | 
| 49 | 0 |  |  |  |  | 0 | @result = @$param; | 
| 50 |  |  |  |  |  |  | }elsif($refparam eq 'HASH') { | 
| 51 | 0 |  |  |  |  | 0 | @result = @{$param}{@names}; | 
|  | 0 |  |  |  |  | 0 |  | 
| 52 |  |  |  |  |  |  | }else { | 
| 53 | 0 |  |  |  |  | 0 | $result[0] = $param; | 
| 54 |  |  |  |  |  |  | } | 
| 55 | 0 | 0 |  |  |  | 0 | return wantarray ? @result : $result[0]; | 
| 56 |  |  |  |  |  |  | } | 
| 57 |  |  |  |  |  |  |  | 
| 58 |  |  |  |  |  |  | sub config_directory { | 
| 59 | 0 |  |  | 0 | 0 | 0 | return File::Spec->catfile(File::HomeDir->my_home, ".busybird"); | 
| 60 |  |  |  |  |  |  | } | 
| 61 |  |  |  |  |  |  |  | 
| 62 |  |  |  |  |  |  | sub config_file_path { | 
| 63 | 0 |  |  | 0 | 0 | 0 | my (@paths) = @_; | 
| 64 | 0 |  |  |  |  | 0 | return File::Spec->catfile(config_directory, @paths); | 
| 65 |  |  |  |  |  |  | } | 
| 66 |  |  |  |  |  |  |  | 
| 67 |  |  |  |  |  |  | sub vivifiable_as { | 
| 68 | 71 |  | 100 | 71 | 0 | 350 | return !defined($_[0]) || ref($_[0]) eq $_[1]; | 
| 69 |  |  |  |  |  |  | } | 
| 70 |  |  |  |  |  |  |  | 
| 71 |  |  |  |  |  |  | sub _epoch_undef { | 
| 72 | 2916 |  |  | 2916 |  | 78528 | my ($datetime_str) = @_; | 
| 73 | 2916 |  |  |  |  | 7012 | my $dt = BusyBird::DateTime::Format->parse_datetime($datetime_str); | 
| 74 | 2916 | 100 |  |  |  | 1659430 | return defined($dt) ? $dt->epoch : undef; | 
| 75 |  |  |  |  |  |  | } | 
| 76 |  |  |  |  |  |  |  | 
| 77 |  |  |  |  |  |  | sub _sort_compare { | 
| 78 | 3513 |  |  | 3513 |  | 2637 | my ($a, $b) = @_; | 
| 79 | 3513 | 100 | 100 |  |  | 11642 | if(defined($a) && defined($b)) { | 
|  |  | 100 | 100 |  |  |  |  | 
|  |  | 100 | 66 |  |  |  |  | 
| 80 | 2355 |  |  |  |  | 2212 | return $b <=> $a; | 
| 81 |  |  |  |  |  |  | }elsif(!defined($a) && defined($b)) { | 
| 82 | 73 |  |  |  |  | 104 | return -1; | 
| 83 |  |  |  |  |  |  | }elsif(defined($a) && !defined($b)) { | 
| 84 | 222 |  |  |  |  | 248 | return 1; | 
| 85 |  |  |  |  |  |  | }else { | 
| 86 | 863 |  |  |  |  | 965 | return 0; | 
| 87 |  |  |  |  |  |  | } | 
| 88 |  |  |  |  |  |  | } | 
| 89 |  |  |  |  |  |  |  | 
| 90 |  |  |  |  |  |  | sub sort_statuses { | 
| 91 | 92 |  |  | 92 | 1 | 10870 | my ($statuses) = @_; | 
| 92 | 17 |  |  | 17 |  | 8225 | use sort 'stable'; | 
|  | 17 |  |  |  |  | 7435 |  | 
|  | 17 |  |  |  |  | 81 |  | 
| 93 |  |  |  |  |  |  |  | 
| 94 | 1458 |  |  |  |  | 17208 | my @dt_statuses = map { | 
| 95 | 92 |  |  |  |  | 195 | my $safe_status = safed($_); | 
| 96 |  |  |  |  |  |  | [ | 
| 97 | 1458 |  |  |  |  | 3307 | $_, | 
| 98 |  |  |  |  |  |  | _epoch_undef($safe_status->val("busybird", "acked_at")), | 
| 99 |  |  |  |  |  |  | _epoch_undef($safe_status->val("created_at")), | 
| 100 |  |  |  |  |  |  | ]; | 
| 101 |  |  |  |  |  |  | } @$statuses; | 
| 102 | 1458 |  |  |  |  | 2094 | return [ map { $_->[0] } sort { | 
| 103 | 92 |  |  |  |  | 1489 | foreach my $sort_key (1, 2) { | 
|  | 1958 |  |  |  |  | 1749 |  | 
| 104 | 3513 |  |  |  |  | 4347 | my $ret = _sort_compare($a->[$sort_key], $b->[$sort_key]); | 
| 105 | 3513 | 100 |  |  |  | 5906 | return $ret if $ret != 0; | 
| 106 |  |  |  |  |  |  | } | 
| 107 | 61 |  |  |  |  | 59 | return 0; | 
| 108 |  |  |  |  |  |  | } @dt_statuses]; | 
| 109 |  |  |  |  |  |  | } | 
| 110 |  |  |  |  |  |  |  | 
| 111 |  |  |  |  |  |  | sub _create_text_segment { | 
| 112 |  |  |  |  |  |  | return { | 
| 113 | 94 |  |  | 94 |  | 464 | text => substr($_[0], $_[1], $_[2] - $_[1]), | 
| 114 |  |  |  |  |  |  | start => $_[1], | 
| 115 |  |  |  |  |  |  | end => $_[2], | 
| 116 |  |  |  |  |  |  | type => $_[3], | 
| 117 |  |  |  |  |  |  | entity => $_[4], | 
| 118 |  |  |  |  |  |  | }; | 
| 119 |  |  |  |  |  |  | } | 
| 120 |  |  |  |  |  |  |  | 
| 121 |  |  |  |  |  |  | sub split_with_entities { | 
| 122 | 32 |  |  | 32 | 1 | 15490 | my ($text, $entities_hashref) = @_; | 
| 123 | 17 |  |  | 17 |  | 3902 | use sort 'stable'; | 
|  | 17 |  |  |  |  | 29 |  | 
|  | 17 |  |  |  |  | 61 |  | 
| 124 | 32 | 100 |  |  |  | 96 | if(!defined($text)) { | 
| 125 | 1 |  |  |  |  | 181 | croak "text must not be undef"; | 
| 126 |  |  |  |  |  |  | } | 
| 127 | 31 | 100 |  |  |  | 73 | if(ref($entities_hashref) ne "HASH") { | 
| 128 | 12 |  |  |  |  | 31 | return [_create_text_segment($text, 0, length($text))]; | 
| 129 |  |  |  |  |  |  | } | 
| 130 |  |  |  |  |  |  |  | 
| 131 |  |  |  |  |  |  | ## create entity segments | 
| 132 | 19 |  |  |  |  | 24 | my @entity_segments = (); | 
| 133 | 19 |  |  |  |  | 51 | foreach my $entity_type (keys %$entities_hashref) { | 
| 134 | 50 |  |  |  |  | 54 | my $entities = $entities_hashref->{$entity_type}; | 
| 135 | 50 | 100 |  |  |  | 87 | next if ref($entities) ne "ARRAY"; | 
| 136 | 49 |  |  |  |  | 56 | foreach my $entity (@$entities) { | 
| 137 | 46 |  |  |  |  | 106 | my $se = safed($entity); | 
| 138 | 46 |  |  |  |  | 86 | my $start = $se->val("indices", 0); | 
| 139 | 46 |  |  |  |  | 1504 | my $end = $se->val("indices", 1); | 
| 140 | 46 | 100 | 100 |  |  | 1425 | if(defined($start) && defined($end) && $start <= $end) { | 
|  |  |  | 100 |  |  |  |  | 
| 141 | 41 |  |  |  |  | 62 | push(@entity_segments, _create_text_segment( | 
| 142 |  |  |  |  |  |  | $text, $start, $end, $entity_type, $entity | 
| 143 |  |  |  |  |  |  | )); | 
| 144 |  |  |  |  |  |  | } | 
| 145 |  |  |  |  |  |  | } | 
| 146 |  |  |  |  |  |  | } | 
| 147 | 19 |  |  |  |  | 53 | @entity_segments = sort { $a->{start} <=> $b->{start} } @entity_segments; | 
|  | 36 |  |  |  |  | 52 |  | 
| 148 |  |  |  |  |  |  |  | 
| 149 |  |  |  |  |  |  | ## combine entity_segments with non-entity segments | 
| 150 | 19 |  |  |  |  | 18 | my $pos = 0; | 
| 151 | 19 |  |  |  |  | 22 | my @final_segments = (); | 
| 152 | 19 |  |  |  |  | 24 | foreach my $entity_segment (@entity_segments) { | 
| 153 | 41 | 100 |  |  |  | 76 | if($pos < $entity_segment->{start}) { | 
| 154 | 30 |  |  |  |  | 40 | push(@final_segments, _create_text_segment( | 
| 155 |  |  |  |  |  |  | $text, $pos, $entity_segment->{start} | 
| 156 |  |  |  |  |  |  | )); | 
| 157 |  |  |  |  |  |  | } | 
| 158 | 41 |  |  |  |  | 43 | push(@final_segments, $entity_segment); | 
| 159 | 41 |  |  |  |  | 52 | $pos = $entity_segment->{end}; | 
| 160 |  |  |  |  |  |  | } | 
| 161 | 19 | 100 |  |  |  | 45 | if($pos < length($text)) { | 
| 162 | 11 |  |  |  |  | 19 | push(@final_segments, _create_text_segment( | 
| 163 |  |  |  |  |  |  | $text, $pos, length($text) | 
| 164 |  |  |  |  |  |  | )); | 
| 165 |  |  |  |  |  |  | } | 
| 166 | 19 |  |  |  |  | 62 | return \@final_segments; | 
| 167 |  |  |  |  |  |  | } | 
| 168 |  |  |  |  |  |  |  | 
| 169 |  |  |  |  |  |  | sub future_of { | 
| 170 | 296 |  |  | 296 | 1 | 24412 | my ($invocant, $method, %args) = @_; | 
| 171 |  |  |  |  |  |  | return Future::Q->try(sub { | 
| 172 | 296 | 100 |  | 296 |  | 10752 | croak "invocant parameter is mandatory" if not defined $invocant; | 
| 173 | 295 | 100 |  |  |  | 652 | croak "method parameter is mandatory" if not defined $method; | 
| 174 | 294 | 100 |  |  |  | 1187 | croak "invocant is not blessed" if not blessed $invocant; | 
| 175 | 293 | 100 |  |  |  | 1087 | croak "no such method as $method" if not $invocant->can($method); | 
| 176 | 292 |  |  |  |  | 872 | my $f = Future::Q->new(); | 
| 177 |  |  |  |  |  |  | $invocant->$method(%args, callback => sub { | 
| 178 | 287 |  |  |  |  | 7553 | my ($error, @results) = @_; | 
| 179 | 287 | 100 |  |  |  | 536 | if($error) { | 
| 180 | 6 |  |  |  |  | 23 | $f->reject($error, 1); | 
| 181 |  |  |  |  |  |  | }else { | 
| 182 | 281 |  |  |  |  | 1109 | $f->fulfill(@results); | 
| 183 |  |  |  |  |  |  | } | 
| 184 | 292 |  |  |  |  | 5409 | }); | 
| 185 | 287 |  |  |  |  | 14250 | return $f; | 
| 186 | 296 |  |  |  |  | 1911 | }); | 
| 187 |  |  |  |  |  |  | } | 
| 188 |  |  |  |  |  |  |  | 
| 189 |  |  |  |  |  |  | sub make_tracking { | 
| 190 | 2 |  |  | 2 | 1 | 9 | my ($tracking_timeline, $main_timeline) = @_; | 
| 191 | 2 | 50 | 33 |  |  | 24 | if(!blessed($tracking_timeline) || !$tracking_timeline->isa("BusyBird::Timeline")) { | 
| 192 | 0 |  |  |  |  | 0 | croak "tracking_timeline must be a BusyBird::Timeline."; | 
| 193 |  |  |  |  |  |  | } | 
| 194 | 2 | 50 | 33 |  |  | 14 | if(!blessed($main_timeline) || !$main_timeline->isa("BusyBird::Timeline")) { | 
| 195 | 0 |  |  |  |  | 0 | croak "main_timeline must be a BusyBird::Timeline."; | 
| 196 |  |  |  |  |  |  | } | 
| 197 | 2 |  |  |  |  | 6 | my $name_tracking = $tracking_timeline->name; | 
| 198 | 2 |  |  |  |  | 4 | my $name_main = $main_timeline->name; | 
| 199 | 2 | 50 |  |  |  | 6 | if($name_tracking eq $name_main) { | 
| 200 | 0 |  |  |  |  | 0 | croak "tracking_timeline and main_timeline must be different timelines."; | 
| 201 |  |  |  |  |  |  | } | 
| 202 | 2 |  |  |  |  | 6 | weaken(my $track = $tracking_timeline); | 
| 203 |  |  |  |  |  |  | $tracking_timeline->add_filter_async(sub { | 
| 204 | 5 |  |  | 5 |  | 9 | my ($statuses, $done) = @_; | 
| 205 | 5 | 50 |  |  |  | 14 | if(!defined($track)) { | 
| 206 | 0 |  |  |  |  | 0 | $done->($statuses); | 
| 207 | 0 |  |  |  |  | 0 | return; | 
| 208 |  |  |  |  |  |  | } | 
| 209 |  |  |  |  |  |  | $track->contains(query => $statuses, callback => sub { | 
| 210 | 5 |  |  |  |  | 10 | my ($error, $contained, $not_contained) = @_; | 
| 211 | 5 | 50 |  |  |  | 14 | if(defined($error)) { | 
| 212 | 0 |  |  |  |  | 0 | bblog("error", "tracking timeline '$name_tracking' contains() error: $error"); | 
| 213 | 0 |  |  |  |  | 0 | $done->($statuses); | 
| 214 | 0 |  |  |  |  | 0 | return; | 
| 215 |  |  |  |  |  |  | } | 
| 216 |  |  |  |  |  |  | $main_timeline->add($not_contained, sub { | 
| 217 | 5 |  |  |  |  | 8 | my ($error, $count) = @_; | 
| 218 | 5 | 50 |  |  |  | 13 | if(defined($error)) { | 
| 219 | 0 |  |  |  |  | 0 | bblog("error", "main timeline '$name_main' add() error: $error"); | 
| 220 |  |  |  |  |  |  | } | 
| 221 | 5 |  |  |  |  | 15 | $done->($statuses); | 
| 222 | 5 |  |  |  |  | 38 | }); | 
| 223 | 5 |  |  |  |  | 35 | }); | 
| 224 | 2 |  |  |  |  | 15 | }); | 
| 225 | 2 |  |  |  |  | 13 | return $tracking_timeline; | 
| 226 |  |  |  |  |  |  | } | 
| 227 |  |  |  |  |  |  |  | 
| 228 |  |  |  |  |  |  | 1; | 
| 229 |  |  |  |  |  |  |  | 
| 230 |  |  |  |  |  |  | __END__ |