use
vars
qw{$VERSION %quotes %sections}
;
BEGIN {
$VERSION
=
'0.995'
;
%sections
= (
'('
=> {
type
=>
'()'
,
_close
=>
')'
},
'<'
=> {
type
=>
'<>'
,
_close
=>
'>'
},
'['
=> {
type
=>
'[]'
,
_close
=>
']'
},
'{'
=> {
type
=>
'{}'
,
_close
=>
'}'
},
);
%quotes
= (
'q'
=> {
operator
=>
'q'
,
braced
=>
undef
,
seperator
=>
undef
,
_sections
=> 1 },
'qq'
=> {
operator
=>
'qq'
,
braced
=>
undef
,
seperator
=>
undef
,
_sections
=> 1 },
'qx'
=> {
operator
=>
'qx'
,
braced
=>
undef
,
seperator
=>
undef
,
_sections
=> 1 },
'qw'
=> {
operator
=>
'qw'
,
braced
=>
undef
,
seperator
=>
undef
,
_sections
=> 1 },
'qr'
=> {
operator
=>
'qr'
,
braced
=>
undef
,
seperator
=>
undef
,
_sections
=> 1,
modifiers
=> 1 },
'm'
=> {
operator
=>
'm'
,
braced
=>
undef
,
seperator
=>
undef
,
_sections
=> 1,
modifiers
=> 1 },
's'
=> {
operator
=>
's'
,
braced
=>
undef
,
seperator
=>
undef
,
_sections
=> 2,
modifiers
=> 1 },
'tr'
=> {
operator
=>
'tr'
,
braced
=>
undef
,
seperator
=>
undef
,
_sections
=> 2,
modifiers
=> 1 },
'y'
=> {
operator
=>
'y'
,
braced
=>
undef
,
seperator
=>
undef
,
_sections
=> 2,
modifiers
=> 1 },
'/'
=> {
operator
=>
undef
,
braced
=> 0,
seperator
=>
'/'
,
_sections
=> 1,
modifiers
=> 1 },
'<'
=> {
operator
=>
undef
,
braced
=> 1,
seperator
=>
undef
,
_sections
=> 1, },
'?'
=> {
operator
=>
undef
,
braced
=> 0,
seperator
=>
'?'
,
_sections
=> 1,
modifieds
=> 1 },
);
}
sub
new {
my
$class
=
shift
;
my
$init
=
defined
$_
[0] ?
shift
:
return
undef
;
my
$self
= PPI::Token::new(
$class
,
$init
) or
return
undef
;
my
$options
=
$quotes
{
$init
} or
return
$self
->_error(
"Unknown quote type '$init'"
);
foreach
(
keys
%$options
) {
$self
->{
$_
} =
$options
->{
$_
};
}
$self
->{modifiers} = {}
if
$self
->{modifiers};
if
(
$init
eq
'<'
) {
$self
->{sections}->[0] = Clone::clone(
$sections
{
'<'
} );
}
$self
;
}
sub
_fill {
my
$class
=
shift
;
my
$t
=
shift
;
my
$self
=
$t
->{token} or
return
undef
;
if
(
$self
->{operator} ) {
if
(
substr
(
$t
->{line},
$t
->{line_cursor}, 1 ) =~ /\s/ ) {
my
$gap
=
$self
->_scan_quote_like_operator_gap(
$t
);
return
undef
unless
defined
$gap
;
if
(
ref
$gap
) {
$self
->{content} .=
$$gap
;
return
0;
}
$self
->{content} .=
$gap
;
}
$_
=
substr
(
$t
->{line},
$t
->{line_cursor}++, 1 );
$self
->{content} .=
$_
;
if
(
my
$section
=
$sections
{
$_
} ) {
$self
->{braced} = 1;
$self
->{sections}->[0] = Clone::clone(
$section
);
}
else
{
$self
->{braced} = 0;
$self
->{seperator} =
$_
;
}
}
$_
=
$self
->{braced}
?
$self
->_fill_braced(
$t
)
:
$self
->_fill_normal(
$t
)
or
return
$_
;
return
1
unless
$self
->{modifiers};
my
$char
;
my
$len
= 0;
while
( (
$char
=
substr
(
$t
->{line},
$t
->{line_cursor} + 1, 1 )) =~ /\w/ ) {
$char
eq
'_'
and
return
$self
->_error(
"Syntax error. Cannot use underscore '_' as regex modifier"
);
$len
++;
$self
->{content} .=
$char
;
$self
->{modifiers}->{
lc
$char
} = 1;
$t
->{line_cursor}++;
}
}
sub
_fill_normal {
my
$self
=
shift
;
my
$t
=
shift
;
my
$string
=
$self
->_scan_for_unescaped_character(
$t
,
$self
->{seperator} );
return
undef
unless
defined
$string
;
if
(
ref
$string
) {
$self
->{content} .=
$$string
;
return
0;
}
$self
->{sections}->[0] = {
position
=>
length
$self
->{content},
size
=>
length
(
$string
) - 1
};
$self
->{content} .=
$string
;
return
1
if
$self
->{_sections} == 1;
$t
->{line_cursor}++;
$string
=
$self
->_scan_for_unescaped_character(
$t
,
$self
->{seperator} );
return
undef
unless
defined
$string
;
if
(
ref
$string
) {
$self
->{content} .=
$$string
;
return
0;
}
$self
->{sections}->[1] = {
position
=>
length
(
$self
->{content}),
size
=>
length
(
$string
) - 1
};
$self
->{content} .=
$string
;
1;
}
sub
_fill_braced {
my
$self
=
shift
;
my
$t
=
shift
;
my
$section
=
$self
->{sections}->[0];
$DB::single
= 1
unless
$section
->{_close};
$_
=
$self
->_scan_for_brace_character(
$t
,
$section
->{_close} );
return
undef
unless
defined
$_
;
if
(
ref
$_
) {
$self
->{content} .=
$$_
;
return
0;
}
$self
->{content} .=
$_
;
$section
->{position} =
length
$self
->{content};
$section
->{size} =
length
(
$_
) - 1;
delete
$section
->{_close};
return
1
if
$self
->{_sections} == 1;
my
$char
=
substr
(
$t
->{line}, ++
$t
->{line_cursor}, 1 );
if
(
$char
=~ /\s/ ) {
$_
=
$self
->_scan_quote_like_operator_gap(
$t
);
return
undef
unless
defined
$_
;
if
(
ref
$_
) {
$self
->{content} .=
$$_
;
return
0;
}
$self
->{content} .=
$_
;
$char
=
substr
(
$t
->{line},
$t
->{line_cursor}, 1 );
}
if
(
$section
=
$sections
{
$char
} ) {
$self
->{content} .=
$char
;
$section
=
$self
->{sections}->[1] = {
%$section
};
}
else
{
return
$self
->_error(
"Syntax error. Second section of regex does not start with an open brace"
);
}
$t
->{line_cursor}++;
$_
=
$self
->_scan_for_brace_character(
$t
,
$section
->{_close} );
return
undef
unless
defined
$_
;
if
(
ref
$_
) {
$self
->{content} .=
$$_
;
return
0;
}
$self
->{content} .=
$_
;
$section
->{position} =
length
$self
->{content};
$section
->{size} =
length
(
$_
) - 1;
delete
$section
->{_close};
1;
}
sub
_sections {
wantarray
? @{
$_
[0]->{sections}} :
scalar
@{
$_
[0]->{sections}} }
1;