$VERSION
= 1 ;
'CMP_SUB'
,
'COMMENT_TIMES'
,
'HAS_CHANGE_IDS'
,
);
sub
_eq {
defined
$_
[0]
?
defined
$_
[1]
?
$_
[0] eq
$_
[1]
: 0
: !
defined
$_
[1];
}
sub
_compile_cmp_sub {
my
VCP::Filter::changesets
$self
=
shift
;
my
(
$rules
) =
@_
;
my
@cmps
=
join
"\n && "
,
map
{
my
(
$field
,
$cond
) =
map
lc
,
@$_
;
my
$cmp
;
if
(
(
$field
eq
"time"
||
$field
eq
"mod_time"
)
&&
$cond
=~ /\A(<|<=)?\d+\z/
) {
$cond
=
"<= $cond"
unless
defined
$1;
$cmp
=
"abs( ( \$ra->time || 0 ) - ( \$rb->time || 0 ) ) $cond"
;
}
elsif
(
$field
eq
"branched_rev_branch_id"
&&
$cond
eq
"equal"
) {
$cmp
=
<<'CMP';
(_eq( $ra->branch_id, $rb->branch_id ) ?
$ra->is_placeholder_rev ? $rb->is_placeholder_rev ? 1 : 0
: !$rb->is_placeholder_rev : 0)
CMP
chomp
$cmp
;
}
elsif
(
$cond
eq
"equal"
) {
$cmp
=
"_eq( \$ra->$field, \$rb->$field )"
;
}
else
{
die
"unknown condition in ChangeSets: rule: $field $cond\n"
;
}
$cmp
;
}
@$rules
;
my
@code
= (
<<PREAMBLE, " ", @cmps, <<POSTAMBLE );
#line 1 VCP::Filter::changesets::in_same_change()
sub {
my ( \$ra, \$rb ) = \@_;
PREAMBLE
;
}
POSTAMBLE
debug
@code
if
debugging;
$self
->{CMP_SUB} =
eval
join
""
,
@code
or
die
"$@ in ChangeSets filter:\n@code"
;
}
sub
new {
my
$class
=
ref
$_
[0] ?
ref
shift
:
shift
;
my
$self
=
$class
->SUPER::new(
@_
) ;
my
(
$spec
,
$options
) =
@_
;
$options
||= [];
$self
->_compile_cmp_sub(
$self
->parse_rules_list(
$options
,
"Field"
,
"Condition"
,
[
[
qw( time 60 )
],
[
qw( user_id equal )
],
[
qw( comment equal )
],
[
qw( branched_rev_branch_id equal )
],
]
)
);
return
$self
;
}
sub
is_sort_filter { 1 }
sub
handle_header {
my
VCP::Filter::changesets
$self
=
shift
;
$self
->revs->set;
$self
->SUPER::handle_header(
@_
);
$self
->{HAS_CHANGE_IDS} = 1;
}
sub
handle_rev {
my
VCP::Filter::changesets
$self
=
shift
;
$self
->{HAS_CHANGE_IDS} &&= !empty
$_
[0]->change_id;
$self
->revs->add(
shift
);
}
sub
_compile_sort_rec_bulk_indexer {
my
(
$rev
,
$spec
) =
@_
;
my
$code
=
join
""
,
q[sub { my $revs = shift; my $r; for my $sr ( @$revs ) { $r = $sr->[0]
;
$sr
->[1] =
pack
'],
map
(
$rev
->pack_format(
$_
),
@$spec
),
q[', ]
,
join
(
", "
,
map
$rev
->index_value_expression(
$_
),
@$spec
),
q[}}]
;
return
(
eval
$code
or
die
$@ );
}
sub
_calc_sort_recs {
my
VCP::Filter::changesets
$self
=
shift
;
my
(
$sort_recs
,
$spec
) =
@_
;
return
unless
@$sort_recs
;
lg
"sort key: "
,
join
", "
,
map
"'$_'"
,
@$spec
;
if
(
grep
/avg_comment_time/,
@$spec
) {
$self
->{COMMENT_TIMES} = {};
for
(
@$sort_recs
) {
my
$r
=
$_
->[0];
my
$comment
=
defined
$r
->comment
?
$r
->comment
:
$r
->is_base_rev ?
""
:
undef
;
my
$time
=
defined
$r
->sort_time
?
$r
->sort_time
:
$r
->is_base_rev ? 0 :
undef
;
next
unless
defined
$comment
&&
defined
$time
;
push
@{
$self
->{COMMENT_TIMES}->{
$comment
}},
$time
;
}
for
(
values
%{
$self
->{COMMENT_TIMES}} ) {
next
unless
@$_
;
my
$sum
;
$sum
+=
$_
for
@$_
;
$_
=
$sum
/
@$_
;
}
}
my
$indexer
= _compile_sort_rec_bulk_indexer(
$sort_recs
->[0]->[0],
$spec
);
$indexer
->(
$sort_recs
);
}
sub
sort_revs_by_change_id {
my
VCP::Filter::changesets
$self
=
shift
;
pr
"sorting revisions by change_id"
;
$self
->revs->set(
sort
{ VCP::Rev->cmp_id(
$a
->change_id,
$b
->change_id ) }
$self
->revs->get
);
}
sub
sort_revs {
my
VCP::Filter::changesets
$self
=
shift
;
my
%rev_kids
;
my
@roots
;
my
@sort_recs
;
pr
"aggregating changes\n"
;
lg
"creating revision trees"
;
for
my
$r
(
$self
->revs->get ) {
my
$sort_rec
= [
$r
,
undef
];
push
@sort_recs
,
$sort_rec
;
if
(
$r
->previous ) {
push
@{
$rev_kids
{
int
$r
->previous}},
$sort_rec
;
}
else
{
push
@roots
,
$sort_rec
;
}
}
lg
"generating index"
;
my
@spec
=
qw( time user_id comment branch_id name )
;
VCP::Rev::preindex;
$self
->_calc_sort_recs( \
@sort_recs
, \
@spec
);
lg
"doing change aggregation"
;
my
@result
;
@roots
=
sort
{
$a
->[1] cmp
$b
->[1] }
@roots
;
my
$change_number
= 0;
my
$in_same_change
=
sub
{
no
warnings
'uninitialized'
;
((
$_
[0]->rev_id eq
$_
[1]->rev_id) &&
$_
[0]->rev_id eq
'1.1'
&&
(
$_
[0]->action eq
$_
[1]->action) &&
$_
[0]->action eq
'delete'
) ||
&{
$self
->{CMP_SUB}} (
@_
);
};
while
(
@roots
) {
++
$change_number
;
my
@change
;
my
@kids
;
do
{
my
(
$r
,
undef
) = @{
shift
@roots
};
push
@change
,
$r
;
my
$kids
=
delete
$rev_kids
{
int
$r
};
push
@kids
,
@$kids
if
$kids
;
}
while
(
@roots
&&
$in_same_change
->(
$change
[-1],
$roots
[0]->[0] )
);
lg
"...change $change_number: "
.
@change
.
" revs"
;
$_
->change_id(
$change_number
)
for
@change
;
push
@result
,
@change
;
if
(
@kids
) {
@kids
=
sort
{
$a
->[1] cmp
$b
->[1] }
@kids
if
@kids
> 1;
if
(
@roots
) {
if
(
$kids
[0]->[1] ge
$roots
[-1]->[1] ) {
push
@roots
,
@kids
;
}
elsif
(
$kids
[-1]->[1] le
$roots
[0]->[1] ) {
unshift
@roots
,
@kids
;
}
else
{
my
@result
;
if
(
@roots
> 5 ) {
my
$i
= 0;
my
$k
=
$kids
[0]->[1];
++
$i
while
$i
<=
$#roots
&&
$k
ge
$roots
[
$i
]->[1];
@result
=
splice
@roots
, 0,
$i
;
}
while
(
@roots
&&
@kids
) {
my
$w
=
$roots
[0]->[1] cmp
$kids
[0]->[1];
if
(
$w
< 0 ) {
push
@result
,
shift
@roots
}
elsif
(
$w
> 0 ) {
push
@result
,
shift
@kids
}
else
{
push
@result
,
shift
@roots
,
shift
@kids
}
}
@roots
= (
@result
,
@roots
,
@kids
);
}
}
else
{
@roots
=
@kids
;
}
}
}
pr
$change_number
,
" changes found"
,
$change_number
?
sprintf
" (%.2f mean revs/change)"
,
$self
->revs->get /
$change_number
: (),
"\n"
;
$self
->revs->set(
@result
);
}
sub
handle_footer {
my
VCP::Filter::changesets
$self
=
shift
;
$self
->{HAS_CHANGE_IDS}
?
$self
->sort_revs_by_change_id
:
$self
->sort_revs;
$self
->SUPER::handle_rev(
$_
)
for
$self
->revs->get;
$self
->revs->remove_all;
$self
->SUPER::handle_footer(
@_
);
}
1