← Back to branch summary

~ubuntu-branches/ubuntu/trusty/libperl5i-perl/trusty-proposed

« back to all changes in this revision

Viewing changes to lib/perl5i/2/SCALAR.pm

  • Committer: Bazaar Package Importer
  • Author(s): Ivan Kohler
  • Date: 2010-05-08 17:42:00 UTC
  • Revision ID: james.westby@ubuntu.com-20100508174200-7ogg0zrimh9gvcuw
Tags: upstream-2.1.1
Import upstream version 2.1.1

Show diffs side-by-side

added added

removed removed

Lines of Context:
lib/perl5i/2/SCALAR.pm
 
1
# vi: set ts=4 sw=4 ht=4 et :
 
2
package perl5i::2::SCALAR;
 
3
use 5.010;
 
4
 
 
5
use strict;
 
6
use warnings;
 
7
require Carp;
 
8
use perl5i::2::autobox;
 
9
 
 
10
sub title_case {
 
11
    my ($string) = @_;
 
12
    $string =~ s/\b(\w)/\U$1/g;
 
13
    return $string;
 
14
}
 
15
 
 
16
 
 
17
sub center {
 
18
    my ($string, $size, $char) = @_;
 
19
    Carp::carp("Use of uninitialized value for size in center()") if !defined $size;
 
20
    $size //= 0;
 
21
    $char //= ' ';
 
22
 
 
23
    if (length $char > 1) {
 
24
        my $bad = $char;
 
25
        $char = substr $char, 0, 1;
 
26
        Carp::carp("'$bad' is longer than one character, using '$char' instead");
 
27
    }
 
28
 
 
29
    my $len             = length $string;
 
30
 
 
31
    return $string if $size <= $len;
 
32
 
 
33
    my $padlen          = $size - $len;
 
34
 
 
35
    # pad right with half the remaining characters
 
36
    my $rpad            = int( $padlen / 2 );
 
37
 
 
38
    # bias the left padding to one more space, if $size - $len is odd
 
39
    my $lpad            = $padlen - $rpad;
 
40
 
 
41
    return $char x $lpad . $string . $char x $rpad;
 
42
}
 
43
 
 
44
 
 
45
sub ltrim {
 
46
    my ($string,$trim_charset) = @_;
 
47
    $trim_charset = '\s' unless defined $trim_charset;
 
48
    my $re = qr/^[$trim_charset]*/;
 
49
    $string =~ s/$re//;
 
50
    return $string;
 
51
}
 
52
 
 
53
 
 
54
sub rtrim {
 
55
    my ($string,$trim_charset) = @_;
 
56
    $trim_charset = '\s' unless defined $trim_charset;
 
57
    my $re = qr/[$trim_charset]*$/;
 
58
    $string =~ s/$re//;
 
59
    return $string;
 
60
}
 
61
 
 
62
 
 
63
sub trim {
 
64
    my $charset = $_[1];
 
65
 
 
66
    return rtrim(ltrim($_[0], $charset), $charset);
 
67
}
 
68
 
 
69
 
 
70
sub wrap {
 
71
    my ($string, %args) = @_;
 
72
 
 
73
    my $width     = $args{width}     // 76;
 
74
    my $separator = $args{separator} // "\n";
 
75
 
 
76
    return $string if $width <= 0;
 
77
 
 
78
    require Text::Wrap;
 
79
    local $Text::Wrap::separator = $separator;
 
80
    local $Text::Wrap::columns   = $width;
 
81
 
 
82
    return Text::Wrap::wrap('', '', $string);
 
83
 
 
84
}
 
85
 
 
86
 
 
87
# untaint the scalar itself, not the reference
 
88
sub untaint {
 
89
    return $_[0]->mo->untaint if ref $_[0];
 
90
 
 
91
    require Taint::Util;
 
92
    Taint::Util::untaint($_[0]);
 
93
    return 1;
 
94
}
 
95
 
 
96
 
 
97
# untaint the scalar itself, not the reference
 
98
sub taint {
 
99
    return $_[0]->mo->taint if ref $_[0];
 
100
 
 
101
    require Taint::Util;
 
102
    Taint::Util::taint($_[0]);
 
103
    return 1;
 
104
}
 
105
 
 
106
# Could use the version in Meta but this removes the need to check
 
107
# for overloading.
 
108
sub is_tainted {
 
109
    require Taint::Util;
 
110
    return ref $_[0] ? Taint::Util::tainted(${$_[0]}) : Taint::Util::tainted($_[0]);
 
111
}
 
112
 
 
113
 
 
114
sub require {
 
115
    my $error = do {
 
116
        # Don't let them leak out or get reset
 
117
        local($!,$@);
 
118
        return $_[0] if eval { require $_[0]->module2path };
 
119
        $@;
 
120
    };
 
121
 
 
122
    my($pack, $file, $line) = caller;
 
123
    $error =~ s{ at .*? line .*?\.\n$}{ at $file line $line.\n};
 
124
    die $error;
 
125
}
 
126
 
 
127
 
 
128
sub alias {
 
129
    Carp::croak(<<ERROR) if !ref $_[0];
 
130
Due to limitations in autoboxing, scalars cannot be aliased.
 
131
Sorry.  Use a scalar reference instead.
 
132
ERROR
 
133
 
 
134
    goto &perl5i::2::UNIVERSAL::alias;
 
135
}
 
136
 
 
137
 
 
138
require POSIX;
 
139
*ceil  = \&POSIX::ceil;
 
140
*floor = \&POSIX::floor;
 
141
*round_up   = \&ceil;
 
142
*round_down = \&floor;
 
143
sub round {
 
144
    return 0 if $_[0] == 0;
 
145
 
 
146
    if( $_[0]->is_positive ) {
 
147
        abs($_[0] - int($_[0])) < 0.5 ? round_down($_[0])
 
148
                                      : round_up($_[0])
 
149
    }
 
150
    else {
 
151
        abs($_[0] - int($_[0])) < 0.5 ? round_up($_[0])
 
152
                                      : round_down($_[0])
 
153
    }
 
154
}
 
155
 
 
156
require Scalar::Util;
 
157
*is_number = \&Scalar::Util::looks_like_number;
 
158
sub is_positive         { $_[0]->is_number && $_[0] > 0 }
 
159
sub is_negative         { $_[0]->is_number && $_[0] < 0 }
 
160
sub is_integer          {
 
161
    return 0 if !$_[0]->is_number;
 
162
    return $_[0] =~ m{ ^[+-]? \d+ $}x;
 
163
}
 
164
*is_int = \&is_integer;
 
165
sub is_decimal          {
 
166
    return 0 if !$_[0]->is_number;
 
167
 
 
168
    # Fast and reliable way to spot most decimals
 
169
    return 1 if ((int($_[0]) - $_[0]) != 0);
 
170
 
 
171
    # Final gate for tricky things like 1.0, 1. and .0
 
172
    return $_[0] =~ m{^ [+-]? (?: \d+\.\d* | \.\d+ ) $}x;
 
173
}
 
174
 
 
175
 
 
176
sub path2module {
 
177
    my $path = shift;
 
178
 
 
179
    my($vol, $dirs, $file) = File::Spec->splitpath($path);
 
180
    my @dirs = grep length, File::Spec->splitdir($dirs);
 
181
 
 
182
    Carp::croak("'$path' does not look like a Perl module path")
 
183
      if $file !~ m{\.pm$} or File::Spec->file_name_is_absolute($path);
 
184
 
 
185
    $file =~ s{\.pm$}{};
 
186
 
 
187
    return join "::", @dirs, $file;
 
188
}
 
189
 
 
190
 
 
191
sub module2path {
 
192
    my $module = shift;
 
193
 
 
194
    my @parts = split /::/, $module;
 
195
    $parts[-1] .= ".pm";
 
196
 
 
197
    return join "/", @parts;
 
198
}
 
199
 
 
200
1;