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