1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
|
# Copyright (c) 1997-2024
# Ewgenij Gawrilow, Michael Joswig, and the polymake team
# Technische Universität Berlin, Germany
# https://polymake.org
#
# This program is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the
# Free Software Foundation; either version 2, or (at your option) any
# later version: http://www.gnu.org/licenses/gpl.txt.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#-------------------------------------------------------------------------------
use strict;
use namespaces;
use warnings qw(FATAL void syntax misc);
use feature 'state';
package Polymake::Core::UpgradeRule;
use Polymake::Struct (
[ new => '$$$' ],
[ '$type' => '#1' ],
[ '$paths' => '#2' ],
[ '$body' => '#3' ],
);
sub new {
my $self = &_new;
if ($self->type eq "ANY_DATA_TYPE" and
defined($self->paths) || !is_code($self->body)) {
croak("ANY_DATA_TYPE rule must have a body and no property path");
}
$self->paths &&= [ map { [ split /\./ ] } split /\s*\|\s*/, $self->paths ];
unless (is_code($self->body)) {
defined($self->paths)
or croak("upgrade rule for an entire object must have a body");
if ($self->body =~ /^delete$/) {
$self->body = sub {
my ($obj, $prop) = @_;
delete $obj->{$prop};
true
};
} elsif (my ($new_name) = $self->body =~ /^rename\s+($prop_name_re)$/) {
$self->body = sub { Polymake::Upgrades::rename_property(@_, $new_name) };
} else {
croak("invalid upgrade rule shortcut " . $self->body);
}
}
$self
}
# can be used in upgrade rules too
sub Polymake::Upgrades::rename_property {
my ($obj, $old_prop_name, $new_prop_name) = @_;
$obj->{$new_prop_name} = delete $obj->{$old_prop_name};
if (my $attrs = $obj->{_attrs}) {
if (defined(my $attr = delete $attrs->{$old_prop_name})) {
$attrs->{$new_prop_name} = $attr;
}
}
true
}
sub Polymake::Upgrades::move_property {
my ($old_obj, $old_prop_name, $new_obj, $new_prop_name) = @_;
$new_prop_name //= $old_prop_name;
$new_obj->{$new_prop_name} = delete $old_obj->{$old_prop_name};
if (my $attrs = $old_obj->{_attrs}) {
if (defined(my $attr = delete $attrs->{$old_prop_name})) {
$new_obj->{_attrs}->{$new_prop_name} = $attr;
}
}
true
}
sub apply {
my ($self, $obj, $attrs) = @_;
if (defined($self->paths)) {
my $cnt = 0;
foreach my $path (@{$self->paths}) {
my $prop = local pop @$path;
my @subobj = ($obj);
foreach my $subprop (@$path) {
@subobj = map { is_array($_) ? @$_ : $_ } grep { defined } map { $_->{$subprop} } @subobj
or last;
}
foreach my $subobj (@subobj) {
if (exists($subobj->{$prop})) {
my $rc = $self->body->($subobj, $prop);
is_integer($rc) or die "upgrade rule ".$self->header." did not return an integer or boolean change indicator\n";
$cnt += $rc;
}
}
}
$cnt
} else {
my $rc = $self->body->($obj, $attrs);
is_integer($rc) or die "upgrade rule ".$self->header." did not return an integer or boolean change indicator\n";
$rc
}
}
sub header {
my ($self) = @_;
my $header = $self->type;
if (defined($self->paths)) {
$header .= "." . join(" | ", map { join(".", @$_) } @{$self->paths});
}
$header
}
1
# Local Variables:
# cperl-indent-level:3
# indent-tabs-mode:nil
# End:
|
