← Back to branch summary

~ubuntu-branches/ubuntu/trusty/drizzle/trusty

« back to all changes in this revision

Viewing changes to tests/kewpie/randgen/lib/GenTest/Simplifier/Grammar.pm

  • Committer: Package Import Robot
  • Author(s): Clint Byrum
  • Date: 2012-06-19 10:46:49 UTC
  • mfrom: (1.1.6)
  • mto: This revision was merged to the branch mainline in revision 29.
  • Revision ID: package-import@ubuntu.com-20120619104649-e2l0ggd4oz3um0f4
Tags: upstream-7.1.36-stable
Import upstream version 7.1.36-stable

Show diffs side-by-side

added added

removed removed

Lines of Context:
tests/kewpie/randgen/lib/GenTest/Simplifier/Grammar.pm
 
1
# Copyright (C) 2008-2009 Sun Microsystems, Inc. All rights reserved.
 
2
# Use is subject to license terms.
 
3
#
 
4
# This program is free software; you can redistribute it and/or modify
 
5
# it under the terms of the GNU General Public License as published by
 
6
# the Free Software Foundation; version 2 of the License.
 
7
#
 
8
# This program is distributed in the hope that it will be useful, but
 
9
# WITHOUT ANY WARRANTY; without even the implied warranty of
 
10
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
 
11
# General Public License for more details.
 
12
#
 
13
# You should have received a copy of the GNU General Public License
 
14
# along with this program; if not, write to the Free Software
 
15
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301
 
16
# USA
 
17
 
 
18
package GenTest::Simplifier::Grammar;
 
19
 
 
20
require Exporter;
 
21
@ISA = qw(GenTest);
 
22
 
 
23
use strict;
 
24
use lib 'lib';
 
25
 
 
26
use GenTest;
 
27
use GenTest::Constants;
 
28
use GenTest::Grammar;
 
29
use GenTest::Grammar::Rule;
 
30
 
 
31
use constant SIMPLIFIER_ORACLE          => 0;
 
32
use constant SIMPLIFIER_CACHE           => 1;
 
33
use constant SIMPLIFIER_GRAMMAR_OBJ     => 2;
 
34
use constant SIMPLIFIER_RULES_VISITED   => 3;
 
35
use constant SIMPLIFIER_GRAMMAR_FLAGS   => 4;
 
36
 
 
37
1;
 
38
 
 
39
sub new {
 
40
        my $class = shift;
 
41
 
 
42
        my $simplifier = $class->SUPER::new({
 
43
                'oracle'        => SIMPLIFIER_ORACLE,
 
44
                'grammar_flags' => SIMPLIFIER_GRAMMAR_FLAGS
 
45
        }, @_);
 
46
 
 
47
        return $simplifier;
 
48
}
 
49
 
 
50
sub simplify {
 
51
        my ($simplifier, $initial_grammar_string) = @_;
 
52
 
 
53
        if ($simplifier->oracle($initial_grammar_string) == ORACLE_ISSUE_NO_LONGER_REPEATABLE) {
 
54
                warn("Initial grammar failed oracle check.");
 
55
                warn("Are duration and/or trials too small or is a different value for seed required?");
 
56
                return undef;
 
57
        }
 
58
        
 
59
        my $grammar_string = $initial_grammar_string;
 
60
 
 
61
        #
 
62
        # We perform the descend() several times, in order to compensate for
 
63
        # our imperfect tree walking algorithm combined with the probability of 
 
64
        # loops in the grammar files.
 
65
        #
 
66
 
 
67
        foreach my $trial (0..1) {
 
68
                $simplifier->[SIMPLIFIER_GRAMMAR_OBJ] = GenTest::Grammar->new(
 
69
                        grammar_string  => $grammar_string,
 
70
                        grammar_flags   => $simplifier->[SIMPLIFIER_GRAMMAR_FLAGS]
 
71
                );
 
72
 
 
73
                return undef if not defined $simplifier->[SIMPLIFIER_GRAMMAR_OBJ];
 
74
 
 
75
                $simplifier->[SIMPLIFIER_RULES_VISITED] = {};
 
76
 
 
77
                $simplifier->descend('query');
 
78
 
 
79
                foreach my $rule (keys %{$simplifier->[SIMPLIFIER_GRAMMAR_OBJ]->rules()}) {
 
80
                        if (not exists $simplifier->[SIMPLIFIER_RULES_VISITED]->{$rule}) {
 
81
                        #       say("Rule $rule is not referenced any more. Removing from grammar.");
 
82
                                $simplifier->[SIMPLIFIER_GRAMMAR_OBJ]->deleteRule($rule);
 
83
                        }
 
84
                }
 
85
 
 
86
                $grammar_string = $simplifier->[SIMPLIFIER_GRAMMAR_OBJ]->toString();
 
87
        }
 
88
        
 
89
        if ($simplifier->oracle($grammar_string) == ORACLE_ISSUE_NO_LONGER_REPEATABLE) {
 
90
                warn("Final grammar failed oracle check.");
 
91
                return undef;
 
92
        } else {
 
93
                return $grammar_string;
 
94
        } 
 
95
}
 
96
 
 
97
sub descend {
 
98
        my ($simplifier, $rule) = @_;
 
99
 
 
100
        my $grammar_obj = $simplifier->[SIMPLIFIER_GRAMMAR_OBJ];
 
101
 
 
102
        my $rule_obj = $grammar_obj->rule($rule);
 
103
        return $rule if not defined $rule_obj;
 
104
 
 
105
        return $rule_obj if exists $simplifier->[SIMPLIFIER_RULES_VISITED]->{$rule};
 
106
        $simplifier->[SIMPLIFIER_RULES_VISITED]->{$rule}++;
 
107
 
 
108
        my $orig_components = $rule_obj->components();
 
109
 
 
110
        for (my $component_id = $#$orig_components; $component_id >= 0; $component_id--) {
 
111
                my $orig_component = $orig_components->[$component_id];
 
112
 
 
113
                # Remove one component and call the oracle to check if the issue is still repeatable
 
114
 
 
115
                say("Attempting to remove component ".join(' ', @$orig_component)." ...");
 
116
 
 
117
                splice (@$orig_components, $component_id, 1);
 
118
                
 
119
                if ($simplifier->oracle($grammar_obj->toString()) != ORACLE_ISSUE_NO_LONGER_REPEATABLE) {
 
120
                        say("Outcome still repeatable after removing ".join(' ', @$orig_component).". Deleting component.");
 
121
                        next;
 
122
                } else {
 
123
                        say("Outcome no longer repeatable after removing ".join(' ', @$orig_component).". Keeping component.");
 
124
 
 
125
                        # Undo the change and dig deeper, into the parts of the rule component
 
126
 
 
127
                        splice (@$orig_components, $component_id, 0, $orig_component);
 
128
 
 
129
                        for (my $part_id = $#{$orig_components->[$component_id]}; $part_id >= 0; $part_id--) {
 
130
 
 
131
                                my $child = $simplifier->descend($orig_components->[$component_id]->[$part_id]);
 
132
 
 
133
                                # If the outcome of the descend() is sufficiently simple, in-line it.
 
134
 
 
135
                                if (ref($child) eq 'GenTest::Grammar::Rule') {
 
136
                                        my $child_name = $child->name();
 
137
                                        if ($#{$child->components()} == -1) {
 
138
                                        #       say("Child $child_name is empty. Removing altogether.");
 
139
                                                splice(@{$orig_components->[$component_id]}, $part_id, 1);
 
140
                                        } elsif ($#{$child->components()} == 0) {
 
141
                                        #       say("Child $child_name has a single component. In-lining.");
 
142
                                                splice(@{$orig_components->[$component_id]}, $part_id, 1, @{$child->components()->[0]});
 
143
                                        }
 
144
                                } else {
 
145
                                #       say("Got a string literal. In-lining.");
 
146
                                        splice(@{$orig_components->[$component_id]}, $part_id, 1, $child);
 
147
                                }
 
148
                        }
 
149
                }
 
150
        }
 
151
 
 
152
        return $rule_obj;
 
153
}
 
154
 
 
155
sub oracle {
 
156
        my ($simplifier, $grammar) = @_;
 
157
 
 
158
        my $cache = $simplifier->[SIMPLIFIER_CACHE];
 
159
        my $oracle = $simplifier->[SIMPLIFIER_ORACLE];
 
160
 
 
161
        $cache->{$grammar} = $oracle->($grammar) if not exists $cache->{$grammar};
 
162
        return $cache->{$grammar};
 
163
}
 
164
 
 
165
1;