1use 5.008;    # utf8
2use strict;
3use warnings;
4use utf8;
5
6package Path::IsDev::Object;
7
8our $VERSION = '1.001002';
9
10# ABSTRACT: Object Oriented guts for IsDev export
11
12our $AUTHORITY = 'cpan:KENTNL'; # AUTHORITY
13
14
15
16
17
18
19
20
21
22
23
24
25
26our $ENV_KEY_DEBUG = 'PATH_ISDEV_DEBUG';
27our $DEBUG = ( exists $ENV{$ENV_KEY_DEBUG} ? $ENV{$ENV_KEY_DEBUG} : undef );
28
29our $ENV_KEY_DEFAULT = 'PATH_ISDEV_DEFAULT_SET';
30our $DEFAULT =
31  ( exists $ENV{$ENV_KEY_DEFAULT} ? $ENV{$ENV_KEY_DEFAULT} : 'Basic' );
32
33
34
35
36
37
38
39
40
41use Class::Tiny 0.010 {
42  set        => sub { $DEFAULT },
43  set_prefix => sub { 'Path::IsDev::HeuristicSet' },
44  set_module => sub {
45    require Module::Runtime;
46    return Module::Runtime::compose_module_name( $_[0]->set_prefix => $_[0]->set );
47  },
48  loaded_set_module => sub {
49    require Module::Runtime;
50    return Module::Runtime::use_module( $_[0]->set_module );
51  },
52};
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72my $instances   = {};
73my $instance_id = 0;
74
75sub _carp { require Carp; goto &Carp::carp; }
76
77
78
79
80
81
82
83
84
85
86
87
88sub _instance_id {
89  my ($self) = @_;
90  require Scalar::Util;
91  my $addr = Scalar::Util::refaddr($self);
92  return $instances->{$addr} if exists $instances->{$addr};
93  $instances->{$addr} = sprintf '%x', $instance_id++;
94  return $instances->{$addr};
95}
96
97
98
99
100
101
102
103
104
105
106
107sub _debug {
108  my ( $self, $message ) = @_;
109
110  return unless $DEBUG;
111  my $id = $self->_instance_id;
112  return *STDERR->printf( qq{[Path::IsDev=%s] %s\n}, $id, $message );
113}
114
115
116
117
118
119
120
121
122
123
124
125
126sub _with_debug {
127  my ( $self, $code ) = @_;
128  require Path::IsDev;
129  ## no critic (ProhibitNoWarnings)
130  no warnings 'redefine';
131  local *Path::IsDev::debug = sub {
132    $self->_debug(@_);
133  };
134  return $code->();
135}
136
137
138
139
140
141
142
143
144
145
146sub BUILD {
147  my ($self) = @_;
148  return $self unless $DEBUG;
149  $self->_debug('{');
150  $self->_debug( ' set               => ' . $self->set );
151  $self->_debug( ' set_prefix        => ' . $self->set_prefix );
152  $self->_debug( ' set_module        => ' . $self->set_module );
153  $self->_debug( ' loaded_set_module => ' . $self->loaded_set_module );
154  $self->_debug('}');
155  return $self;
156}
157
158
159
160
161
162
163
164
165
166
167
168sub _matches {
169  my ( $self, $path ) = @_;
170  require Path::IsDev::Result;
171  my $result_object = Path::IsDev::Result->new( path => $path );
172  my $result;
173  $self->_with_debug(
174    sub {
175
176      $self->_debug( 'Matching ' . $result_object->path );
177      $result = $self->loaded_set_module->matches($result_object);
178    },
179  );
180  if ( !!$result != !!$result_object->result ) {
181    _carp(q[Result and Result Object missmatch]);
182  }
183  return $result_object;
184}
185
186
187
188
189
190
191
192
193
194
195
196sub matches {
197  my ( $self, $path ) = @_;
198
199  my $result_object = $self->_matches($path);
200
201  if ( not $result_object->result ) {
202    $self->_debug('no match found');
203    return;
204  }
205
206  return $result_object->result;
207}
208
2091;
210
211__END__
212
213=pod
214
215=encoding UTF-8
216
217=head1 NAME
218
219Path::IsDev::Object - Object Oriented guts for IsDev export
220
221=head1 VERSION
222
223version 1.001002
224
225=head1 SYNOPSIS
226
227    use Path::IsDev::Object;
228
229    my $dev = Path::IsDev::Object->new();
230    my $dev = Path::IsDev::Object->new( set => 'MySet' );
231
232    if ( $dev->matches($path) ){
233        print "$path is dev";
234    }
235
236=head1 DESCRIPTION
237
238Exporting functions is handy for end users, but quickly
239becomes a huge headache when you're trying to chain them.
240
241e.g: If you're writing an exporter yourself, and you want to wrap
242responses from an exported symbol, while passing through user
243configuration => Huge headache.
244
245So the exporter based interface is there for people who don't need anything fancy,
246while the Object based interface is there for people with more complex requirements.
247
248=head1 METHODS
249
250=head2 C<matches>
251
252Determine if a given path satisfies the C<set>
253
254    if( $o->matches($path) ){
255        print "We have a match!";
256    }
257
258=head1 ATTRIBUTES
259
260=head2 C<set>
261
262The name of the C<HeuristicSet::> to use.
263
264Default is C<Basic>, or the value of C<$ENV{PATH_ISDEV_DEFAULT_SET}>
265
266=head2 C<set_prefix>
267
268The C<HeuristicSet> prefix to use to expand C<set> to a module name.
269
270Default is C<Path::IsDev::HeuristicSet>
271
272=head2 C<set_module>
273
274The fully qualified module name.
275
276Composed by joining C<set> and C<set_prefix>
277
278=head2 C<loaded_set_module>
279
280An accessor which returns a module name after loading it.
281
282=head1 PRIVATE METHODS
283
284=head2 C<_instance_id>
285
286An opportunistic sequence number for help with debug messages.
287
288Note: This is not guaranteed to be unique per instance, only guaranteed
289to be constant within the life of the object.
290
291Based on C<refaddr>, and giving out new ids when new C<refaddr>'s are seen.
292
293=head2 C<_debug>
294
295The debugger callback.
296
297    export PATH_ISDEV_DEBUG=1
298
299to get debug info.
300
301=head2 C<_with_debug>
302
303Wrap calls to Path::IsDev::debug to have a prefix with an object identifier.
304
305    $ob->_with_debug(sub{
306        # Path::Tiny::debug now localised.
307
308    });
309
310=head2 C<BUILD>
311
312C<BUILD> is an implementation detail of C<Class::Tiny>.
313
314This module hooks C<BUILD> to give a self report of the object
315to C<*STDERR> after C<< ->new >> when under C<$DEBUG>
316
317=head2 C<_matches>
318
319    my $result = $o->matches( $path );
320
321$result here will be a constructed C<Path::IsDev::Result>.
322
323Note this method may be handy for debugging, but you should still call C<matches> for all real code.
324
325=begin MetaPOD::JSON v1.1.0
326
327{
328    "namespace":"Path::IsDev::Object",
329    "interface":"class",
330    "inherits":"Class::Tiny::Object"
331}
332
333
334=end MetaPOD::JSON
335
336=head1 AUTHOR
337
338Kent Fredric <kentfredric@gmail.com>
339
340=head1 COPYRIGHT AND LICENSE
341
342This software is copyright (c) 2014 by Kent Fredric <kentfredric@gmail.com>.
343
344This is free software; you can redistribute it and/or modify it under
345the same terms as the Perl 5 programming language system itself.
346
347=cut
348