← Index
NYTProf Performance Profile   « line view »
For svc/members/upsert
  Run on Tue Jan 13 11:50:22 2015
Reported on Tue Jan 13 12:09:50 2015

Filename/usr/share/perl5/Set/Infinite/_recurrence.pm
StatementsExecuted 16 statements in 1.53ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11112µs24µsSet::Infinite::_recurrence::::BEGIN@7Set::Infinite::_recurrence::BEGIN@7
11111µs32µsSet::Infinite::_recurrence::::BEGIN@15Set::Infinite::_recurrence::BEGIN@15
1118µs48µsSet::Infinite::_recurrence::::BEGIN@9Set::Infinite::_recurrence::BEGIN@9
1117µs7µsSet::Infinite::_recurrence::::BEGIN@17Set::Infinite::_recurrence::BEGIN@17
1117µs29µsSet::Infinite::_recurrence::::BEGIN@10Set::Infinite::_recurrence::BEGIN@10
1116µs39µsSet::Infinite::_recurrence::::BEGIN@12Set::Infinite::_recurrence::BEGIN@12
0000s0sSet::Infinite::_recurrence::::__ANON__[:106]Set::Infinite::_recurrence::__ANON__[:106]
0000s0sSet::Infinite::_recurrence::::__ANON__[:233]Set::Infinite::_recurrence::__ANON__[:233]
0000s0sSet::Infinite::_recurrence::::__ANON__[:245]Set::Infinite::_recurrence::__ANON__[:245]
0000s0sSet::Infinite::_recurrence::::__ANON__[:266]Set::Infinite::_recurrence::__ANON__[:266]
0000s0sSet::Infinite::_recurrence::::__ANON__[:271]Set::Infinite::_recurrence::__ANON__[:271]
0000s0sSet::Infinite::_recurrence::::__ANON__[:57]Set::Infinite::_recurrence::__ANON__[:57]
0000s0sSet::Infinite::_recurrence::::__ANON__[:76]Set::Infinite::_recurrence::__ANON__[:76]
0000s0sSet::Infinite::_recurrence::::_is_recurrenceSet::Infinite::_recurrence::_is_recurrence
0000s0sSet::Infinite::_recurrence::::_recurrenceSet::Infinite::_recurrence::_recurrence
0000s0sSet::Infinite::_recurrence::::intersectionSet::Infinite::_recurrence::intersection
0000s0sSet::Infinite::_recurrence::::is_foreverSet::Infinite::_recurrence::is_forever
0000s0sSet::Infinite::_recurrence::::unionSet::Infinite::_recurrence::union
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1# Copyright (c) 2003 Flavio Soibelmann Glock. All rights reserved.
2# This program is free software; you can redistribute it and/or
3# modify it under the same terms as Perl itself.
4
5package Set::Infinite::_recurrence;
6
72432µs237µs
# spent 24µs (12+13) within Set::Infinite::_recurrence::BEGIN@7 which was called: # once (12µs+13µs) by DateTime::Set::BEGIN@10 at line 7
use strict;
# spent 24µs making 1 call to Set::Infinite::_recurrence::BEGIN@7 # spent 13µs making 1 call to strict::import
8
9231µs287µs
# spent 48µs (8+39) within Set::Infinite::_recurrence::BEGIN@9 which was called: # once (8µs+39µs) by DateTime::Set::BEGIN@10 at line 9
use constant INFINITY => 100 ** 100 ** 100 ;
# spent 48µs making 1 call to Set::Infinite::_recurrence::BEGIN@9 # spent 39µs making 1 call to constant::import
10225µs251µs
# spent 29µs (7+22) within Set::Infinite::_recurrence::BEGIN@10 which was called: # once (7µs+22µs) by DateTime::Set::BEGIN@10 at line 10
use constant NEG_INFINITY => -1 * (100 ** 100 ** 100);
# spent 29µs making 1 call to Set::Infinite::_recurrence::BEGIN@10 # spent 22µs making 1 call to constant::import
11
12232µs271µs
# spent 39µs (6+33) within Set::Infinite::_recurrence::BEGIN@12 which was called: # once (6µs+33µs) by DateTime::Set::BEGIN@10 at line 12
use vars qw( @ISA $PRETTY_PRINT $max_iterate );
# spent 39µs making 1 call to Set::Infinite::_recurrence::BEGIN@12 # spent 32µs making 1 call to vars::import
13
1419µs@ISA = qw( Set::Infinite );
153245µs353µs
# spent 32µs (11+21) within Set::Infinite::_recurrence::BEGIN@15 which was called: # once (11µs+21µs) by DateTime::Set::BEGIN@10 at line 15
use Set::Infinite 0.5502;
# spent 32µs making 1 call to Set::Infinite::_recurrence::BEGIN@15 # spent 13µs making 1 call to Exporter::import # spent 9µs making 1 call to version::_VERSION
16
17
# spent 7µs within Set::Infinite::_recurrence::BEGIN@17 which was called: # once (7µs+0s) by DateTime::Set::BEGIN@10 at line 77
BEGIN {
181300ns $PRETTY_PRINT = 1; # enable Set::Infinite debug
191100ns $max_iterate = 20;
20
21 # TODO: inherit %Set::Infinite::_first / _last
22 # in a more "object oriented" way
23
24 $Set::Infinite::_first{_recurrence} =
25 sub {
26 my $self = $_[0];
27 my ($callback_next, $callback_previous) = @{ $self->{param} };
28 my ($min, $min_open) = $self->{parent}->min_a;
29 # my ($max, $max_open) = $self->{parent}->max_a;
30
31 my ( $min1, $min2 );
32 $min1 = $callback_next->( $min );
33 if ( ! $min_open )
34 {
35 $min2 = $callback_previous->( $min1 );
36 $min1 = $min2 if defined $min2 && $min == $min2;
37 }
38
39 my $start = $callback_next->( $min1 );
40 my $end = $self->{parent}->max;
41
42 #print STDERR "set ";
43 #print STDERR $start->datetime
44 # unless $start == INFINITY;
45 #print STDERR " - " ;
46 #print STDERR $end->datetime
47 # unless $end == INFINITY;
48 #print STDERR "\n";
49
50 return ( $self->new( $min1 ), undef )
51 if $start > $end;
52
53 return ( $self->new( $min1 ),
54 $self->new( $start, $end )->
55 # $self->new( {a => $start, b => $end, open_end => $max_open} )->
56 _function( '_recurrence', @{ $self->{param} } ) );
5712µs };
58 $Set::Infinite::_last{_recurrence} =
59 sub {
60 my $self = $_[0];
61 my ($callback_next, $callback_previous) = @{ $self->{param} };
62 my ($max, $max_open) = $self->{parent}->max_a;
63
64 my ( $max1, $max2 );
65 $max1 = $callback_previous->( $max );
66 if ( ! $max_open )
67 {
68 $max2 = $callback_next->( $max1 );
69 $max1 = $max2 if $max == $max2;
70 }
71
72 return ( $self->new( $max1 ),
73 $self->new( $self->{parent}->min,
74 $callback_previous->( $max1 ) )->
75 _function( '_recurrence', @{ $self->{param} } ) );
7615µs };
771751µs17µs}
# spent 7µs making 1 call to Set::Infinite::_recurrence::BEGIN@17
78
79# $si->_recurrence(
80# \&callback_next, \&callback_previous )
81#
82# Generates "recurrences" from a callback.
83# These recurrences are simple lists of dates.
84#
85# The recurrence generation is based on an idea from Dave Rolsky.
86#
87
88# use Data::Dumper;
89# use Carp qw(cluck);
90
91sub _recurrence {
92 my $set = shift;
93 my ( $callback_next, $callback_previous, $delta ) = @_;
94
95 $delta->{count} = 0 unless defined $delta->{delta};
96
97 # warn "reusing delta: ". $delta->{count} if defined $delta->{delta};
98 # warn Dumper( $delta );
99
100 if ( $#{ $set->{list} } != 0 || $set->is_too_complex )
101 {
102 return $set->iterate(
103 sub {
104 $_[0]->_recurrence(
105 $callback_next, $callback_previous, $delta )
106 } );
107 }
108 # $set is a span
109 my $result;
110 if ($set->min != NEG_INFINITY && $set->max != INFINITY)
111 {
112 # print STDERR " finite set\n";
113 my ($min, $min_open) = $set->min_a;
114 my ($max, $max_open) = $set->max_a;
115
116 my ( $min1, $min2 );
117 $min1 = $callback_next->( $min );
118 if ( ! $min_open )
119 {
120 $min2 = $callback_previous->( $min1 );
121 $min1 = $min2 if defined $min2 && $min == $min2;
122 }
123
124 $result = $set->new();
125
126 # get "delta" - abort if this will take too much time.
127
128 unless ( defined $delta->{max_delta} )
129 {
130 for ( $delta->{count} .. 10 )
131 {
132 if ( $max_open )
133 {
134 return $result if $min1 >= $max;
135 }
136 else
137 {
138 return $result if $min1 > $max;
139 }
140 push @{ $result->{list} },
141 { a => $min1, b => $min1, open_begin => 0, open_end => 0 };
142 $min2 = $callback_next->( $min1 );
143
144 if ( $delta->{delta} )
145 {
146 $delta->{delta} += $min2 - $min1;
147 }
148 else
149 {
150 $delta->{delta} = $min2 - $min1;
151 }
152 $delta->{count}++;
153 $min1 = $min2;
154 }
155
156 $delta->{max_delta} = $delta->{delta} * 40;
157 }
158
159 if ( $max < $min + $delta->{max_delta} )
160 {
161 for ( 1 .. 200 )
162 {
163 if ( $max_open )
164 {
165 return $result if $min1 >= $max;
166 }
167 else
168 {
169 return $result if $min1 > $max;
170 }
171 push @{ $result->{list} },
172 { a => $min1, b => $min1, open_begin => 0, open_end => 0 };
173 $min1 = $callback_next->( $min1 );
174 }
175 }
176
177 # cluck "give up";
178 }
179
180 # return a "_function", such that we can backtrack later.
181 my $func = $set->_function( '_recurrence', $callback_next, $callback_previous, $delta );
182
183 # removed - returning $result doesn't help on speed
184 ## return $func->_function2( 'union', $result ) if $result;
185
186 return $func;
187}
188
189sub is_forever
190{
191 $#{ $_[0]->{list} } == 0 &&
192 $_[0]->max == INFINITY &&
193 $_[0]->min == NEG_INFINITY
194}
195
196sub _is_recurrence
197{
198 exists $_[0]->{method} &&
199 $_[0]->{method} eq '_recurrence' &&
200 $_[0]->{parent}->is_forever
201}
202
203sub intersection
204{
205 my ($s1, $s2) = (shift,shift);
206
207 if ( exists $s1->{method} && $s1->{method} eq '_recurrence' )
208 {
209 # optimize: recurrence && span
210 return $s1->{parent}->
211 intersection( $s2, @_ )->
212 _recurrence( @{ $s1->{param} } )
213 unless ref($s2) && exists $s2->{method};
214
215 # optimize: recurrence && recurrence
216 if ( $s1->{parent}->is_forever &&
217 ref($s2) && _is_recurrence( $s2 ) )
218 {
219 my ( $next1, $previous1 ) = @{ $s1->{param} };
220 my ( $next2, $previous2 ) = @{ $s2->{param} };
221 return $s1->{parent}->_function( '_recurrence',
222 sub {
223 # intersection of parent 'next' callbacks
224 my ($n1, $n2);
225 my $iterate = 0;
226 $n2 = $next2->( $_[0] );
227 while(1) {
228 $n1 = $next1->( $previous1->( $n2 ) );
229 return $n1 if $n1 == $n2;
230 $n2 = $next2->( $previous2->( $n1 ) );
231 return if $iterate++ == $max_iterate;
232 }
233 },
234 sub {
235 # intersection of parent 'previous' callbacks
236 my ($p1, $p2);
237 my $iterate = 0;
238 $p2 = $previous2->( $_[0] );
239 while(1) {
240 $p1 = $previous1->( $next1->( $p2 ) );
241 return $p1 if $p1 == $p2;
242 $p2 = $previous2->( $next2->( $p1 ) );
243 return if $iterate++ == $max_iterate;
244 }
245 },
246 );
247 }
248 }
249 return $s1->SUPER::intersection( $s2, @_ );
250}
251
252sub union
253{
254 my ($s1, $s2) = (shift,shift);
255 if ( $s1->_is_recurrence &&
256 ref($s2) && _is_recurrence( $s2 ) )
257 {
258 # optimize: recurrence || recurrence
259 my ( $next1, $previous1 ) = @{ $s1->{param} };
260 my ( $next2, $previous2 ) = @{ $s2->{param} };
261 return $s1->{parent}->_function( '_recurrence',
262 sub { # next
263 my $n1 = $next1->( $_[0] );
264 my $n2 = $next2->( $_[0] );
265 return $n1 < $n2 ? $n1 : $n2;
266 },
267 sub { # previous
268 my $p1 = $previous1->( $_[0] );
269 my $p2 = $previous2->( $_[0] );
270 return $p1 > $p2 ? $p1 : $p2;
271 },
272 );
273 }
274 return $s1->SUPER::union( $s2, @_ );
275}
276
277=head1 NAME
278
279Set::Infinite::_recurrence - Extends Set::Infinite with recurrence functions
280
281=head1 SYNOPSIS
282
283 $recurrence = $base_set->_recurrence ( \&next, \&previous );
284
285=head1 DESCRIPTION
286
287This is an internal class used by the DateTime::Set module.
288The API is subject to change.
289
290It provides all functionality provided by Set::Infinite, plus the ability
291to define recurrences with arbitrary objects, such as dates.
292
293=head1 METHODS
294
295=over 4
296
297=item * _recurrence ( \&next, \&previous )
298
299Creates a recurrence set. The set is defined inside a 'base set'.
300
301 $recurrence = $base_set->_recurrence ( \&next, \&previous );
302
303The recurrence functions take one argument, and return the 'next' or
304the 'previous' occurrence.
305
306Example: defines the set of all 'integer numbers':
307
308 use strict;
309
310 use Set::Infinite::_recurrence;
311 use POSIX qw(floor);
312
313 # define the recurrence span
314 my $forever = Set::Infinite::_recurrence->new(
315 Set::Infinite::_recurrence::NEG_INFINITY,
316 Set::Infinite::_recurrence::INFINITY
317 );
318
319 my $recurrence = $forever->_recurrence(
320 sub { # next
321 floor( $_[0] + 1 )
322 },
323 sub { # previous
324 my $tmp = floor( $_[0] );
325 $tmp < $_[0] ? $tmp : $_[0] - 1
326 },
327 );
328
329 print "sample recurrence ",
330 $recurrence->intersection( -5, 5 ), "\n";
331 # sample recurrence -5,-4,-3,-2,-1,0,1,2,3,4,5
332
333 {
334 my $x = 234.567;
335 print "next occurence after $x = ",
336 $recurrence->{param}[0]->( $x ), "\n"; # 235
337 print "previous occurence before $x = ",
338 $recurrence->{param}[2]->( $x ), "\n"; # 234
339 }
340
341 {
342 my $x = 234;
343 print "next occurence after $x = ",
344 $recurrence->{param}[0]->( $x ), "\n"; # 235
345 print "previous occurence before $x = ",
346 $recurrence->{param}[2]->( $x ), "\n"; # 233
347 }
348
349=item * is_forever
350
351Returns true if the set is a single span,
352ranging from -Infinity to Infinity.
353
354=item * _is_recurrence
355
356Returns true if the set is an unbounded recurrence,
357ranging from -Infinity to Infinity.
358
359=back
360
361=head1 CONSTANTS
362
363=over 4
364
365=item * INFINITY
366
367The C<Infinity> value.
368
369=item * NEG_INFINITY
370
371The C<-Infinity> value.
372
373=back
374
375=head1 SUPPORT
376
377Support is offered through the C<datetime@perl.org> mailing list.
378
379Please report bugs using rt.cpan.org
380
381=head1 AUTHOR
382
383Flavio Soibelmann Glock <fglock@gmail.com>
384
385The recurrence generation algorithm is based on an idea from Dave Rolsky.
386
387=head1 COPYRIGHT
388
389Copyright (c) 2003 Flavio Soibelmann Glock. All rights reserved.
390This program is free software; you can distribute it and/or
391modify it under the same terms as Perl itself.
392
393The full text of the license can be found in the LICENSE file
394included with this module.
395
396=head1 SEE ALSO
397
398Set::Infinite
399
400DateTime::Set
401
402For details on the Perl DateTime Suite project please see
403L<http://datetime.perl.org>.
404
405=cut
406
Report produced by the NYTProf 5.06 Perl profiler, developed by Tim Bunce and Adam Kaplan.