← Back to branch summary

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

« back to all changes in this revision

Viewing changes to src/core/Str.pm

  • 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/core/Str.pm
 
1
our $?TABSTOP = 8;
 
2
 
 
3
augment class Str does Stringy {
 
4
 
 
5
    multi method Bool { ?(pir::istrue__IP(self)); }
 
6
 
 
7
    method Str() { self }
 
8
 
 
9
    my @KNOWN_ENCODINGS = <utf-8 iso-8859-1 ascii>;
 
10
 
 
11
    # XXX: We have no $?ENC or $?NF compile-time constants yet.
 
12
    multi method encode($encoding is copy = 'utf-8', $nf = '') {
 
13
        if $encoding eq 'latin-1' {
 
14
            $encoding = 'iso-8859-1';
 
15
        }
 
16
        die "Unknown encoding $encoding"
 
17
            unless $encoding.lc eq any @KNOWN_ENCODINGS;
 
18
        $encoding .= lc;
 
19
        my @bytes = Q:PIR {
 
20
            .local int byte
 
21
            .local pmc bytebuffer, it, result
 
22
            $P0 = find_lex 'self'
 
23
            $S0 = $P0
 
24
            $P1 = find_lex '$encoding'
 
25
            $S1 = $P1
 
26
            if $S1 == 'ascii'      goto transcode_ascii
 
27
            if $S1 == 'iso-8859-1' goto transcode_iso_8859_1
 
28
            # NOTE: There's an assumption here, that all strings coming in
 
29
            #       from the rest of Rakudo are always in UTF-8 form. Don't
 
30
            #       know if this assumption always holds; to be on the safe
 
31
            #       side, we might transcode even to UTF-8.
 
32
            goto finished_transcoding
 
33
          transcode_ascii:
 
34
            $I0 = find_encoding 'ascii'
 
35
            $S0 = trans_encoding $S0, $I0
 
36
            goto finished_transcoding
 
37
          transcode_iso_8859_1:
 
38
            $I0 = find_encoding 'iso-8859-1'
 
39
            $S0 = trans_encoding $S0, $I0
 
40
          finished_transcoding:
 
41
            bytebuffer = new ['ByteBuffer']
 
42
            bytebuffer = $S0
 
43
 
 
44
            result = new ['Parcel']
 
45
            it = iter bytebuffer
 
46
          bytes_loop:
 
47
            unless it goto done
 
48
            byte = shift it
 
49
            push result, byte
 
50
            goto bytes_loop
 
51
          done:
 
52
            %r = result
 
53
        };
 
54
        return Buf.new(@bytes);
 
55
    }
 
56
 
 
57
    # Zero indent does nothing
 
58
    multi method indent($steps as Int where { $_ == 0 }) {
 
59
        self;
 
60
    }
 
61
 
 
62
    # Positive indent does indent
 
63
    multi method indent($steps as Int where { $_ > 0 }) {
 
64
    # We want to keep trailing \n so we have to .comb explicitly instead of .lines
 
65
        return self.comb(/:r ^^ \N* \n?/).map({
 
66
            given $_ {
 
67
                # Use the existing space character if they're all the same
 
68
                # (but tabs are done slightly differently)
 
69
                when /^(\t+) ([ \S .* | $ ])/ {
 
70
                    $0 ~ "\t" x ($steps div $?TABSTOP) ~
 
71
                         ' '  x ($steps mod $?TABSTOP) ~ $1
 
72
                }
 
73
                when /^(\h) $0* [ \S | $ ]/ {
 
74
                    $0 x $steps ~ $_
 
75
                }
 
76
 
 
77
                # Otherwise we just insert spaces after the existing leading space
 
78
                default {
 
79
                    ($_ ~~ /^(\h*) (.*)$/).join(' ' x $steps)
 
80
                }
 
81
            }
 
82
        }).join;
 
83
    }
 
84
 
 
85
    # Negative values and Whatever-* do outdent
 
86
    multi method indent($steps) {
 
87
        # Loop through all lines to get as much info out of them as possible
 
88
        my @lines = self.comb(/:r ^^ \N* \n?/).map({
 
89
            # Split the line into indent and content
 
90
            my ($indent, $rest) = @($_ ~~ /^(\h*) (.*)$/);
 
91
 
 
92
            # Split the indent into characters and annotate them
 
93
            # with their visual size
 
94
            my $indent-size = 0;
 
95
            my @indent-chars = $indent.comb.map(-> $char {
 
96
                my $width = $char eq "\t"
 
97
                    ?? $?TABSTOP - ($indent-size mod $?TABSTOP)
 
98
                    !! 1;
 
99
                $indent-size += $width;
 
100
                $char => $width;
 
101
            });
 
102
 
 
103
            { :$indent-size, :@indent-chars, :$rest };
 
104
        });
 
105
 
 
106
        # Figure out the amount * should outdent by, we also use this for warnings
 
107
        my $common-prefix = [min] @lines.map({ $_<indent-size> });
 
108
 
 
109
        # Set the actual outdent amount here
 
110
        my Int $outdent = $steps ~~ Whatever ?? $common-prefix
 
111
                                             !! -$steps;
 
112
 
 
113
        warn sprintf('Asked to remove %d spaces, ' ~
 
114
                     'but the shortest indent is %d spaces',
 
115
                     $outdent, $common-prefix) if $outdent > $common-prefix;
 
116
 
 
117
        # Work backwards from the right end of the indent whitespace, removing
 
118
        # array elements up to # (or over, in the case of tab-explosion)
 
119
        # the specified outdent amount.
 
120
        @lines.map({
 
121
            my $pos = 0;
 
122
            while $_<indent-chars> and $pos < $outdent {
 
123
                $pos += $_<indent-chars>.pop.value;
 
124
            }
 
125
            $_<indent-chars>».key.join ~ ' ' x ($pos - $outdent) ~ $_<rest>;
 
126
        }).join;
 
127
    }
 
128
 
 
129
    our sub str2num-int($src) {
 
130
        Q:PIR {
 
131
            .local pmc src
 
132
            .local string src_s
 
133
            src = find_lex '$src'
 
134
            src_s = src
 
135
            .local int pos, eos
 
136
            .local num result
 
137
            pos = 0
 
138
            eos = length src_s
 
139
            result = 0
 
140
          str_loop:
 
141
            unless pos < eos goto str_done
 
142
            .local string char
 
143
            char = substr src_s, pos, 1
 
144
            if char == '_' goto str_next
 
145
            .local int digitval
 
146
            digitval = index "0123456789", char
 
147
            if digitval < 0 goto err_base
 
148
            if digitval >= 10 goto err_base
 
149
            result *= 10
 
150
            result += digitval
 
151
          str_next:
 
152
            inc pos
 
153
            goto str_loop
 
154
          err_base:
 
155
        src.'panic'('Invalid radix conversion of "', char, '"')
 
156
          str_done:
 
157
            %r = box result
 
158
        };
 
159
    }
 
160
 
 
161
    our sub str2num-base($src) {
 
162
        Q:PIR {
 
163
            .local pmc src
 
164
            .local string src_s
 
165
            src = find_lex '$src'
 
166
            src_s = src
 
167
            .local int pos, eos
 
168
            .local num result
 
169
            pos = 0
 
170
            eos = length src_s
 
171
            result = 1
 
172
          str_loop:
 
173
            unless pos < eos goto str_done
 
174
            .local string char
 
175
            char = substr src_s, pos, 1
 
176
            if char == '_' goto str_next
 
177
            result *= 10
 
178
          str_next:
 
179
            inc pos
 
180
            goto str_loop
 
181
          err_base:
 
182
        src.'panic'('Invalid radix conversion of "', char, '"')
 
183
          str_done:
 
184
            %r = box result
 
185
        };
 
186
    }
 
187
 
 
188
    sub chop-trailing-zeros($i) {
 
189
        Q:PIR {
 
190
            .local int idx
 
191
            $P0 = find_lex '$i'
 
192
            $S0 = $P0
 
193
            idx = length $S0
 
194
        repl_loop:
 
195
            if idx == 0 goto done
 
196
            dec idx
 
197
            $S1 = substr $S0, idx, 1
 
198
            if $S1 == '0' goto repl_loop
 
199
        done:
 
200
            inc idx
 
201
            $S0 = substr $S0, 0, idx
 
202
            $P0 = $S0
 
203
            %r = $P0
 
204
        }
 
205
    }
 
206
 
 
207
    our sub str2num-rat($negate, $int-part, $frac-part is copy) is export {
 
208
        $frac-part = chop-trailing-zeros($frac-part);
 
209
        my $result = upgrade_to_num_if_needed(str2num-int($int-part))
 
210
                     + upgrade_to_num_if_needed(str2num-int($frac-part))
 
211
                       / upgrade_to_num_if_needed(str2num-base($frac-part));
 
212
        $result = -$result if $negate;
 
213
        $result;
 
214
    }
 
215
 
 
216
    our sub str2num-num($negate, $int-part, $frac-part, $exp-part-negate, $exp-part) is export {
 
217
        my $exp = str2num-int($exp-part);
 
218
        $exp = -$exp if $exp-part-negate;
 
219
        my $result = (str2num-int($int-part) + str2num-int($frac-part) / str2num-base($frac-part))
 
220
                     * 10 ** $exp;
 
221
        $result = -$result if $negate;
 
222
        $result;
 
223
    }
 
224
}