view release on metacpan or  search on metacpan

lib/Daizu/Util.pm  view on Meta::CPAN

Returns an escaped version of C<$s> suitable for including in patterns
given to the SQL C<LIKE> operator.  Does NOT escape quotes, so you still
need to quote the result for the database before including it in any SQL.

Returns C<undef> if the input is undefined.

Escapes backslashes, underscores, and percent signs.

=cut

sub like_escape
{
    my ($s) = @_;
    return unless defined $s;
    $s =~ s/([\\_%])/\\$1/g;
    return $s;
}

=item pgregex_escape($s)

Returns an escaped version of C<$s> suitable for including in patterns
given to PostgreSQL's SQL S<C<~> operator>.  Does NOT escape quotes, so you
still need to quote the result for the database before including it in any SQL.

Returns C<undef> if the input is undefined.

Escapes the following characters:
C<. ^ $ + * ? ( ) [ ] { \>

=cut

sub pgregex_escape
{
    my ($s) = @_;
    return unless defined $s;
    $s =~ s/([.^\$+*?()\[\]{\\])/\\$1/g;
    return $s;
}

=item url_encode($s)

Returns a URL encoded version of C<$s>, with characters which would be
unsuitable for use in a URL escaped as C<%> followed by two uppercase
hexadecimal digits.  The opposite of L<url_decode()|/url_decode($s)>.

=cut

sub url_encode
{
    my ($s) = @_;
    $s = encode('UTF-8', $s, Encode::FB_CROAK);

    $s =~ s{([^-.,/_a-zA-Z0-9 ])}{sprintf('%%%02X', ord $1)}ge;
    $s =~ tr/ /+/;

    return decode('UTF-8', $s, Encode::FB_CROAK);
}

=item url_decode($s)

If C<$s> is URL encoded, return a decoded version.  The opposite
of L<url_encode()|/url_encode($s)>.

=cut

sub url_decode
{
    my ($s) = @_;
    $s = encode('UTF-8', $s, Encode::FB_CROAK);

    $s =~ tr/+/ /;
    $s =~ s/%([\da-fA-F]{2})/chr hex $1/eg;

    return decode('UTF-8', $s, Encode::FB_CROAK);
}

=item validate_number($num)

If C<$num> consists only of a sequence of digits, return it as an
untainted number, otherwise return nothing.

=cut

sub validate_number
{
    my ($num) = @_;
    return unless $num =~ /\A(\d+)\z/;
    return $1;
}

=item validate_uri($uri)

Return a L<URI> object representing the absolute URI in C<$uri>, or undef
if it isn't defined, is invalid, or isn't absolute.

This is based on code from the L<Data::Validate::URI> module, but it has
been changed to only allow absolute URIs, and it doesn't try to reconstruct
the URI from it individual parts (something which the URI module can do
instead).

=cut

sub validate_uri
{
    my ($uri) = @_;
    $uri = trim($uri);
    return undef unless defined $uri;

    # Check for illegal characters.
    return undef if $uri =~ /[^-a-zA-Z0-9:\/?#[\]@!\$&'()*+,;=._~]/;

    my ($scheme, $authority, $path, $query) = $uri =~ m{
        \A
        (?: ([a-zA-Z][-+.a-zA-Z0-9]*) :)    # scheme (required)
        (?: // ([^/?#]*) )?                 # authority (optional)
        ([^?#]*)                            # path (including domain, etc.)
        (?: \? ([^#]*) )?                   # query string (optional)
        (?: \# .* )?                        # fragment (optional)
        \z
    }x;
    return undef unless defined $scheme;