Bivio::Type::Regexp
# Copyright (c) 2008 bivio Software, Inc. All Rights Reserved. # $Id$ package Bivio::Type::Regexp; use strict; use Bivio::Base 'Bivio::Type'; sub add_regexp_modifiers { my($self, $value, $modifiers) = @_; $value = $self->from_literal_or_die($value) . ''; $value =~ s{\(\?\^([a-z]*)}{\(?${1}d-xism}sg; $value =~ s{\(\?([a-z]*)(?:-([a-z]+))?}{'(?' . _add_regexp_modifiers($1, $2, $modifiers)}e; return $self->from_literal_or_die($value); } sub from_literal { my($self, $value) = @_; return !defined($value) || !length($value) ? (undef, undef) : ref($value) eq 'Regexp' ? $value : _compile($value); return; } sub from_sql_column { return shift->from_literal_or_die(@_); } sub to_literal { my(undef, $value) = @_; return $value ? "$value" : ''; } sub get_width { return 500; } sub is_stringified_regexp { my(undef, $value) = @_; return !$value ? 0 : $value =~ /^\(\?.*\)$/s ? 1 : 0; } sub quote_string { my(undef, $value) = @_; $value =~ s/(\W)/\\$1/sg; return $value; } sub to_sql_param { return shift->to_literal(@_); } sub to_string { return shift->to_literal(@_); } sub _add_regexp_modifiers { my($curr_plus, $curr_minus, $add) = @_; $curr_minus ||= ''; $add .= $curr_plus || ''; return join( '', map($curr_minus =~ s{([$add])}{} && $1, 1 .. length($add)), $curr_minus ? "-$curr_minus" : (), ); } sub _compile { my($value) = @_; # Perl puts an extra (?-xism:) or (?^:) [perl 5.14+] in front of all # variables converted to # regular expressions. This is problematic as the value would grow # every time from_sql_column is called. This prevents this, but # depends on the fact that the unique leading value is (?-xism: or (?^ $value =~ s/^\(\?(?:\-xism|\^)\:(.*)\)$/$1/si; return (undef, Bivio::TypeError->PERMISSION_DENIED) if $value =~ /\(\?(?!\<\!|\<\=|\!|=|\w|\:|\#|\-|\^)/; return (undef, undef) unless length($value); my($res) = Bivio::Die->eval(sub {qr{$value}}); return (undef, Bivio::TypeError->SYNTAX_ERROR) unless $res; return $res; } 1;