1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
|
use strict;
use warnings;
package File::Util::Interface::Classic;
{
$File::Util::Interface::Classic::VERSION = '4.132140';
}
# ABSTRACT: Legacy call interface to File::Util
use Scalar::Util qw( blessed );
use lib 'lib';
use File::Util::Definitions qw( :all );
use vars qw(
@ISA $AUTHORITY
@EXPORT_OK %EXPORT_TAGS
);
use Exporter;
$AUTHORITY = 'cpan:TOMMY';
@ISA = qw( Exporter );
@EXPORT_OK = qw(
_myargs
_remove_opts
_names_values
);
%EXPORT_TAGS = ( all => [ @EXPORT_OK ] );
# --------------------------------------------------------
# File::Util::Interface::Classic::_myargs()
# --------------------------------------------------------
sub _myargs {
shift @_ if ( blessed $_[0] || ( $_[0] && $_[0] =~ /^File::Util/ ) );
return wantarray ? @_ : $_[0]
}
# --------------------------------------------------------
# File::Util::Interface::Classic::_remove_opts()
# --------------------------------------------------------
sub _remove_opts {
shift; # we don't need "$this" here
my $args = shift @_;
return unless ref $args eq 'ARRAY';
my @triage = @$args; @$args = ();
my $opts = { };
while ( @triage ) {
my $arg = shift @triage;
# if an argument is '', 0, or undef, it's obviously not an --option ...
push @$args, $arg and next unless $arg; # ...so give it back to the @$args
# hmmm. looks like an "--option" argument, if:
if ( $arg =~ /^--/ ) {
# it's either a bare "--option", or it's an "--option=value" pair
my ( $opt, $value ) = split /=/, $arg;
# bare version
$opts->{ $opt } = defined $value ? $value : 1;
# ^^^^^^^ if $value is undef, it was a --flag (true)
# sanitized version, remove leading "--" ...
my $clean_name = substr $opt, 2;
# ...and replace non-alnum chars with "_" so the names can be
# referenced as hash keys without superfluous quoting and escaping
$clean_name =~ s/[^[:alnum:]]/_/g;
$opts->{ $clean_name } = defined $value ? $value : 1;
}
else {
# but if it's not an "--option" type arg, give it back to the @$args
push @$args, $arg;
}
}
return $opts;
}
# --------------------------------------------------------
# File::Util::Interface::Classic::_names_values()
# --------------------------------------------------------
sub _names_values {
shift; # we don't need "$this" here
my @in_pairs = @_;
my $out_pairs = { };
# this code no longer tries to catch foolishness such as names that are
# undef other than skipping over them, for lack of sane options to deal
# with such insane input ;-)
while ( my ( $name, $val ) = splice @in_pairs, 0, 2 ) {
next unless defined $name;
$out_pairs->{ $name } = $val;
}
return $out_pairs;
}
# --------------------------------------------------------
# File::Util::Interface::Classic::DESTROY()
# --------------------------------------------------------
sub DESTROY { }
1;
__END__
=pod
=head1 NAME
File::Util::Interface::Classic - Legacy call interface to File::Util
=head1 VERSION
version 4.132140
=head1 DESCRIPTION
Provides a classic interface for argument passing to and between the public
and private methods of File::Util. It is as a subclass for File::Util
developers that want to use it, and provides some base methods that are
inherited by L<File::Util::Interface::Modern>, but the _remove_opts method
is overridden in that namespace, whose more progressive version of that
method supports both ::Classic and ::Modern call syntaxes.
Users, don't use this module by itself. It is intended for internal use only.
=cut
|
