#!/usr/bin/env perl
if
(
@ARGV
!= 2 ) {
warn
"Expected: delta_deps OLD.JSON NEW.JSON"
;
}
my
$transcoder
= JSON->new();
my
$left
=
$transcoder
->decode( path(
$ARGV
[0] )->slurp );
my
$right
=
$transcoder
->decode( path(
$ARGV
[1] )->slurp );
my
$lp
=
$left
->{prereqs};
my
$rp
=
$right
->{prereqs};
sub
get_type {
if
( not
exists
$_
[0]->{b} and
exists
$_
[0]->{a} ) {
return
'removed'
;
}
if
(
exists
$_
[0]->{b} and not
exists
$_
[0]->{a} ) {
return
'added'
;
}
if
(
exists
$_
[0]->{b} and
exists
$_
[0]->{a} ) {
return
'changed'
;
}
die
"Unhandled combination"
;
}
sub
get_phase {
return
$_
[0]->{path}->[0] .
' '
.
$_
[0]->{path}->[1];
}
sub
get_module {
return
$_
[0]->{path}->[2];
}
my
$cache
;
sub
cache_key {
my
(
$type
,
$phase
) =
@_
;
return
'Dependencies::'
.
ucfirst
(
$type
) .
' / '
.
$phase
;
}
sub
add_dep {
my
(
$phase
,
$module
,
$version
) =
@_
;
my
$cache_key
= cache_key(
'Added'
,
$phase
);
my
$dep_cache
= (
$cache
->{
$cache_key
} ||= [] );
if
(
$version
eq
'0'
) {
push
@{
$dep_cache
},
$module
;
return
;
}
push
@{
$dep_cache
},
$module
.
' '
.
$version
;
return
;
}
sub
remove_dep {
my
(
$phase
,
$module
,
$version
) =
@_
;
my
$cache_key
= cache_key(
'Removed'
,
$phase
);
my
$dep_cache
= (
$cache
->{
$cache_key
} ||= [] );
if
(
$version
eq
'0'
) {
push
@{
$dep_cache
},
$module
;
return
;
}
push
@{
$dep_cache
},
$module
.
' '
.
$version
;
return
;
}
sub
change_dep {
my
(
$phase
,
$module
,
$old_version
,
$new_version
) =
@_
;
my
$cache_key
= cache_key(
'Changed'
,
$phase
);
my
$dep_cache
= (
$cache
->{
$cache_key
} ||= [] );
push
@{
$dep_cache
},
$module
.
' '
.
$old_version
.
chr
(0xA0) .
chr
(0x2192) .
chr
(0xA0) .
$new_version
;
}
sub
cache_change {
my
(
$type
,
$path
,
$remove
,
$add
) =
@_
;
if
(
$type
eq
'added'
) {
return
add_dep(
$path
->[0] .
' '
.
$path
->[1],
$path
->[2],
$add
);
}
if
(
$type
eq
'removed'
) {
return
remove_dep(
$path
->[0] .
' '
.
$path
->[1],
$path
->[2],
$remove
);
}
if
(
$type
eq
'changed'
) {
return
change_dep(
$path
->[0] .
' '
.
$path
->[1],
$path
->[2],
$remove
,
$add
);
}
die
"unknown type $type"
;
}
sub
change_rel {
my
(
$type
,
$path
,
$remove
,
$add
) =
@_
;
if
(
$type
eq
'added'
) {
for
my
$key
(
sort
keys
%{
$add
} ) {
my
$new_path
= [ @{
$path
},
$key
];
cache_change(
$type
,
$new_path
,
undef
,
$add
->{
$key
} );
}
return
;
}
if
(
$type
eq
'removed'
) {
for
my
$key
(
sort
keys
%{
$remove
} ) {
my
$new_path
= [ @{
$path
},
$key
];
cache_change(
$type
,
$new_path
,
$remove
->{
$key
},
undef
);
}
return
;
}
die
"Unhandled change_rel $type"
;
}
sub
change_phase {
my
(
$type
,
$path
,
$remove
,
$add
) =
@_
;
if
(
$type
eq
'added'
) {
for
my
$key
(
sort
keys
%{
$add
} ) {
my
$new_path
= [ @{
$path
},
$key
];
change_rel(
$type
,
$new_path
,
undef
,
$add
->{
$key
} );
}
return
;
}
if
(
$type
eq
'removed'
) {
for
my
$key
(
sort
keys
%{
$remove
} ) {
my
$new_path
= [ @{
$path
},
$key
];
change_rel(
$type
,
$new_path
,
$remove
->{
$key
},
undef
);
}
return
;
}
die
"Unhandled change_phase $type"
;
}
for
my
$d
( data_diff(
$lp
,
$rp
) ) {
my
$type
= get_type(
$d
);
if
(
scalar
@{
$d
->{path} } == 3 ) {
cache_change(
$type
,
$d
->{path},
$d
->{a},
$d
->{b} );
next
;
}
if
(
scalar
@{
$d
->{path} } == 2 ) {
change_rel(
$type
,
$d
->{path},
$d
->{a},
$d
->{b} );
next
;
}
if
(
scalar
@{
$d
->{path} } == 1 ) {
change_phase(
$type
,
$d
->{path},
$d
->{a},
$d
->{b} );
next
;
}
die
"Path not a known length"
;
}
binmode
(
*STDOUT
,
':utf8'
);
for
my
$key
(
sort
keys
%{
$cache
} ) {
print
' ['
.
$key
.
']'
;
print
qq[\n]
;
for
my
$entry
( @{
$cache
->{
$key
} } ) {
print
' - '
.
$entry
.
qq[\n]
;
}
print
qq[\n]
;
}