← Back to branch summary

~ubuntu-branches/ubuntu/precise/rakudo/precise

« back to all changes in this revision

Viewing changes to src/metamodel/RoleToRoleApplier.nqp

  • Committer: Bazaar Package Importer
  • Author(s): Alessandro Ghedini
  • Date: 2011-05-17 11:31:09 UTC
  • mfrom: (1.1.2 upstream)
  • Revision ID: james.westby@ubuntu.com-20110517113109-rmfir654u1axbpt4
Tags: 0.1~2011.04-1
http://bugs.debian.org/601862
http://bugs.debian.org/585762
http://bugs.debian.org/577502
http://bugs.debian.org/584498
* New upstream release (Closes: #601862, #585762, #577502)
* New maintainer
* Switch to 3.0 (quilt) format
* Update dependencies (Closes: #584498)
* Update debian/copyright to lastest DEP5 revision
* Do not generate/install perl6 manpage (now done by the build system)
* Enable tests
* Bump Standards-Version to 3.9.2 (no changes needed)
* Do not install extra LICENSE files and duplicated docs
* Remove debian/clean (no more needed)
* Add Vcs-* fields in debian/control
* Rewrite (short) description
* Update upstream copyright years
* Upload to unstable

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/metamodel/RoleToRoleApplier.nqp
 
1
=begin
 
2
 
 
3
=head1 TITLE
 
4
 
 
5
Perl6::Metamodel::RoleToRoleApplier
 
6
 
 
7
=head1 DESCRIPTION
 
8
 
 
9
Applies roles to another role.
 
10
 
 
11
=head1 METHODS
 
12
 
 
13
=over 4
 
14
 
 
15
=item apply(target, composees)
 
16
 
 
17
Applies all of the composees to target.
 
18
 
 
19
=end
 
20
 
 
21
class Perl6::Metamodel::RoleToRoleApplier;
 
22
 
 
23
method apply($target, @composees) {
 
24
    # Aggregate all of the methods sharing names.
 
25
    my %meth_info;
 
26
    for @composees {
 
27
        my @methods := $_.HOW.methods($_);
 
28
        for @methods {
 
29
            my $name := ~$_;
 
30
            my $meth := $_;
 
31
            my @meth_list;
 
32
            if pir::defined(%meth_info{$name}) {
 
33
                @meth_list := %meth_info{$name};
 
34
            }
 
35
            else {
 
36
                %meth_info{$name} := @meth_list;
 
37
            }
 
38
            my $found := 0;
 
39
            for @meth_list {
 
40
                if $meth =:= $_ {
 
41
                    $found := 1;
 
42
                }
 
43
            }
 
44
            unless $found {
 
45
                @meth_list.push($meth);
 
46
            }
 
47
        }
 
48
    }
 
49
 
 
50
    # Also need methods of target.
 
51
    my %target_meth_info;
 
52
    my @target_meths := $target.HOW.methods($target);
 
53
    for @target_meths {
 
54
        %target_meth_info{~$_} := $_;
 
55
    }
 
56
 
 
57
    # Process method list.
 
58
    for %meth_info {
 
59
        my $name := ~$_;
 
60
        my @add_meths := %meth_info{$name};
 
61
 
 
62
        # Do we already have a method of this name? If so, ignore all of the
 
63
        # methods we have from elsewhere unless it's multi.
 
64
        if pir::defined(%target_meth_info{$name}) {
 
65
            if %target_meth_info{$name}.multi {
 
66
                # Add them anyway.
 
67
                for @add_meths {
 
68
                    $target.HOW.add_method($target, $name, $_);
 
69
                }
 
70
            }
 
71
        }
 
72
        else {
 
73
            # No methods in the target role. If only one, it's easy...
 
74
            if +@add_meths == 1 {
 
75
                $target.HOW.add_method($target, $name, @add_meths[0]);
 
76
            }
 
77
            else {
 
78
                # More than one - add to collisions list unless all multi.
 
79
                my $num_multi := 0;
 
80
                for @add_meths {
 
81
                    if $_.multi { $num_multi := $num_multi + 1; }
 
82
                }
 
83
                if +@add_meths == $num_multi {
 
84
                    for @add_meths {
 
85
                        $target.HOW.add_method($target, $name, $_);
 
86
                    }
 
87
                }
 
88
                else {
 
89
                    $target.HOW.add_collision($target, $name);
 
90
                }
 
91
            }
 
92
        }
 
93
    }
 
94
 
 
95
    # Now do the other bits.
 
96
    my @all_composees;
 
97
    for @composees {
 
98
        my $how := $_.HOW;
 
99
 
 
100
        # Compose is any attributes, unless there's a conflict.
 
101
        my @attributes := $how.attributes($_);
 
102
        for @attributes {
 
103
            my $add_attr := $_;
 
104
            my $skip := 0;
 
105
            my @cur_attrs := $target.HOW.attributes($target, :local(1));
 
106
            for @cur_attrs {
 
107
                if $_ =:= $add_attr {
 
108
                    $skip := 1;
 
109
                }
 
110
                else {
 
111
                    if $_.name eq $add_attr.name {
 
112
                        pir::die("Attribute '" ~ $_.name ~ "' conflicts in role composition");
 
113
                    }
 
114
                }
 
115
            }
 
116
            unless $skip {
 
117
                $target.HOW.add_attribute($target, $add_attr);
 
118
            }
 
119
        }
 
120
 
 
121
        # Pass along any requirements.
 
122
        my @requirements := $how.requirements($_);
 
123
        for @requirements {
 
124
            $target.HOW.add_requirement($target, $_);
 
125
        }
 
126
 
 
127
        # Pass along any parents.
 
128
        my @parents := $how.parents($_);
 
129
        for @parents {
 
130
            $target.HOW.add_parent($target, $_);
 
131
        }
 
132
 
 
133
        # Build up full list.
 
134
        my @composees := $how.composees($_, :transitive(1));
 
135
        for @composees {
 
136
            @all_composees.push($_);
 
137
        }
 
138
    }
 
139
 
 
140
    return @all_composees;
 
141
}
 
142
 
 
143
=begin
 
144
 
 
145
=back
 
146
 
 
147
=end