Class-Usul

 view release on metacpan or  search on metacpan

lib/Class/Usul/Functions.pm  view on Meta::CPAN

   for (my $i = 0, my $j = 0; $len > 0; $len -= 3, $i += 3) {
      my $c1 = ord $x[ $i ]; my $c2 = $len > 1 ? ord $x[ $i + 1 ] : 0;

      $y[ $j++ ] = $basis->[ $c1 >> 2 ];
      $y[ $j++ ] = $basis->[ (($c1 & 0x3) << 4) | (($c2 & 0xF0) >> 4) ];

      if ($len > 2) {
         my $c3 = ord $x[ $i + 2 ];

         $y[ $j++ ] = $basis->[ (($c2 & 0xF) << 2) | (($c3 & 0xC0) >> 6) ];
         $y[ $j++ ] = $basis->[ $c3 & 0x3F ];
      }
      elsif ($len == 2) {
         $y[ $j++ ] = $basis->[ ($c2 & 0xF) << 2 ];
         $y[ $j++ ] = $basis->[ 64 ];
      }
      else { # len == 1
         $y[ $j++ ] = $basis->[ 64 ];
         $y[ $j++ ] = $basis->[ 64 ];
      }
   }

   return join q(), @y;
}

sub bsonid (;$) {
   return unpack 'H*', $_bsonid->( $_[ 0 ] );
}

sub bsonid_time ($) {
   return unpack 'N', substr hex2str( $_[ 0 ] ), 0, 4;
}

sub bson64id (;$) {
   return base64_encode_ns( $_bsonid->( 2 ) );
}

sub bson64id_time ($) {
   return unpack 'N', substr base64_decode_ns( $_[ 0 ] ), 2, 4;
}

sub canonicalise ($;$) {
   my ($base, $relpath) = @_;

   $base = is_arrayref( $base ) ? catdir( @{ $base } ) : $base;
   $relpath or return canonpath( untaint_path( $base ) );

   my @relpath = is_arrayref( $relpath ) ? @{ $relpath } : $relpath;
   my $path    = canonpath( untaint_path( catdir( $base, @relpath ) ) );

   -d $path and return $path;

   return canonpath( untaint_path( catfile( $base, @relpath ) ) );
}

sub class2appdir ($) {
   return lc distname( $_[ 0 ] );
}

sub classdir ($) {
   return catdir( split m{ :: }mx, $_[ 0 ] // q() );
}

sub classfile ($) {
   return catfile( split m{ :: }mx, $_[ 0 ].'.pm' );
}

sub create_token (;$) {
   return digest( $_[ 0 ] // urandom() )->hexdigest;
}

sub create_token64 (;$) {
   return digest( $_[ 0 ] // urandom() )->b64digest;
}

sub cwdp () {
   return abs_path( curdir );
}

sub dash2under (;$) {
  (my $v = $_[ 0 ] // q()) =~ s{ [\-] }{_}gmx; return $v;
}

sub data_dumper (;@) {
   _data_dumper( @_ ); return 1;
}

sub digest ($) {
   my $seed = shift; my ($candidate, $digest);

   if ($digest_cache) { $digest = Digest->new( $digest_cache ) }
   else {
      for (DIGEST_ALGORITHMS) {
         $candidate = $_; $digest = eval { Digest->new( $candidate ) } and last;
      }

      $digest or throw( 'Digest algorithm not found' );
      $digest_cache = $candidate;
   }

   $digest->add( $seed );

   return $digest;
}

sub distname ($) {
   (my $v = $_[ 0 ] // q()) =~ s{ :: }{-}gmx; return $v;
}

#head2 downgrade
#   $sv_pv = downgrade $sv_pvgv;
#Horrendous Perl bug is promoting C<PV> and C<PVMG> type scalars to
#C<PVGV>. Serializing these values with L<Storable> throws a can't
#store SCALAR items error. This functions copies the string value of
#the input scalar to the output scalar but resets the output scalar
#type to C<PV>
#sub downgrade (;$) {
#   my $x = shift // q(); my ($y) = $x =~ m{ (.*) }msx; return $y;
#}

sub elapsed () {
   return time - $BASETIME;
}

sub emit (;@) {

lib/Class/Usul/Functions.pm  view on Meta::CPAN

sub find_apphome ($;$$) {
   my ($appclass, $default, $extns) = @_; my $path;

   # 0. Pass the directory in (short circuit the search)
   $path = assert_directory $default and return $path;

   my $app_pref = app_prefix   $appclass;
   my $appdir   = class2appdir $appclass;
   my $classdir = classdir     $appclass;
   my $env_pref = env_prefix   $appclass;
   my $my_home  = File::HomeDir->my_home;

   # 1a.   Environment variable - for application directory
   $path = assert_directory $ENV{ "${env_pref}_HOME" } and return $path;
   # 1b.   Environment variable - for config file
   $path = $_get_env_var_for_conf->( "${env_pref}_CONFIG" ) and return $path;
   # 2a.   Users XDG_DATA_HOME env variable or XDG default share directory
   $path = $ENV{ 'XDG_DATA_HOME' } // catdir( $my_home, '.local', 'share' );
   $path = assert_directory catdir( $path, $appdir ) and return $path;
   # 2b.   Users home directory - dot file containing shell env variable
   $path = $_get_file_var->( $my_home, $app_pref, $classdir ) and return $path;
   $path = $_get_file_var->( $my_home, $appdir,   $classdir ) and return $path;
   # 2c.   Users home directory - dot directory is apphome
   $path = catdir( $my_home, ".${app_pref}" );
   $path = assert_directory $path and return $path;
   $path = catdir( $my_home, ".${appdir}" );
   $path = assert_directory $path and return $path;
   # 3.    Well known path containing shell env file
   $path = $_get_known_file_var->( $appdir, $classdir ) and return $path;
   # 4.    Default install prefix
   $path = catdir( @{ PREFIX() }, $appdir, 'default', 'lib', $classdir );
   $path = assert_directory $path and return $path;
   # 5a.   Config file found in @INC - underscore as separator
   $path = $_find_cfg_in_inc->( $classdir, $app_pref, $extns ) and return $path;
   # 5b.   Config file found in @INC - dash as separator
   $path = $_find_cfg_in_inc->( $classdir, $appdir,   $extns ) and return $path;
   # 6.    Default to /tmp
   return  untaint_path( DEFAULT_CONFHOME );
}

sub find_source ($) {
   my $class = shift; my $file = classfile( $class ); my $path;

   for (@INC) {
      $path = abs_path( catfile( $_, $file ) ) and -f $path and return $path;
   }

   return;
}

sub first_char ($) {
   return substr $_[ 0 ], 0, 1;
}

sub fqdn (;$) {
   my $x = shift // hostname; return (gethostbyname( $x ))[ 0 ];
}

sub fullname () {
   my $v = (split m{ \s* , \s * }msx, (get_user()->gecos // q()))[ 0 ];

   $v //= q(); $v =~ s{ [\&] }{}gmx; # Coz af25e158-d0c7-11e3-bdcb-31d9eda79835

   return untaint_cmdline( $v );
}

sub get_cfgfiles ($;$$) {
   my ($appclass, $dirs, $extns) = @_;

   $appclass // throw( Unspecified, [ 'application class' ], level => 2 );
   is_arrayref( $dirs ) or $dirs = [ $dirs || curdir ];

   my $app_pref = app_prefix   $appclass;
   my $appdir   = class2appdir $appclass;
   my $env_pref = env_prefix   $appclass;
   my $suffix   = $ENV{ "${env_pref}_CONFIG_LOCAL_SUFFIX" } // '_local';
   my @paths    = ();

   for my $dir (@{ $dirs }) {
      for my $extn (@{ $extns // [ supported_extensions() ] }) {
         for my $path (map { $_catpath->( $dir, $_ ) } "${app_pref}${extn}",
                       "${appdir}${extn}", "${app_pref}${suffix}${extn}",
                       "${appdir}${suffix}${extn}") {
            -f $path and push @paths, $path;
         }
      }
   }

   return \@paths;
}

sub get_user (;$) {
   my $user = shift; is_win32() and return Class::Null->new;

   defined $user and $user !~ m{ \A \d+ \z }mx and return getpwnam( $user );

   return getpwuid( $user // $UID );
}

sub hex2str (;$) {
   my @a = split m{}mx, shift // q(); my $str = q();

   while (my ($x, $y) = splice @a, 0, 2) { $str .= pack 'C', hex "${x}${y}" }

   return $str;
}

sub home2appldir ($) {
   $_[ 0 ] or return; my $dir = io( $_[ 0 ] );

   $dir = $dir->parent while ($dir ne $dir->parent and $dir !~ m{ lib \z }mx);

   return $dir ne $dir->parent ? $dir->parent : undef;
}

sub io (;@) {
   return File::DataClass::IO->new( @_ );
}

sub is_arrayref (;$) {
   return $_[ 0 ] && ref $_[ 0 ] eq 'ARRAY' ? 1 : 0;
}

sub is_coderef (;$) {
   return $_[ 0 ] && ref $_[ 0 ] eq 'CODE' ? 1 : 0;
}

sub is_hashref (;$) {
   return $_[ 0 ] && ref $_[ 0 ] eq 'HASH' ? 1 : 0;
}

sub is_member (;@) {
   my ($candidate, @args) = @_; $candidate or return;

   is_arrayref $args[ 0 ] and @args = @{ $args[ 0 ] };

   return (first { $_ eq $candidate } @args) ? 1 : 0;
}

sub is_ntfs  () {
   return is_win32() || lc $OSNAME eq 'cygwin' ? 1 : 0;
}

sub is_win32 () {
   return lc $OSNAME eq 'mswin32' ? 1 : 0;
}

sub list_attr_of ($;@) {
   my ($obj, @except) = @_; my $class = blessed $obj;

   ensure_class_loaded( 'Pod::Eventual::Simple' );

   is_member 'new', @except or push @except, 'new';

   return map  { my $attr = $_->[0]; [ @{ $_ }, $obj->$attr ] }
          map  { [ $_->[1], $_->[0], $_get_pod_content_for_attr->( @{ $_ } ) ] }
          grep { $_->[0] ne 'Moo::Object' and not is_member $_->[1], @except }
          map  { m{ \A (.+) \:\: ([^:]+) \z }mx; [ $1, $2 ] }
              @{ Class::Inspector->methods( $class, 'full', 'public' ) };
}

lib/Class/Usul/Functions.pm  view on Meta::CPAN

sub logname (;$) { # Deprecated use loginid
   return untaint_cmdline( $ENV{USER} || $ENV{LOGNAME} || loginid( $_[ 0 ] ) );
}

sub merge_attributes ($@) {
   my ($dest, @args) = @_;

   my $attr = is_arrayref( $args[ -1 ] ) ? pop @args : [];

   for my $k (grep { not exists $dest->{ $_ } or not defined $dest->{ $_ } }
                  @{ $attr }) {
      my $i = 0; my $v;

      while (not defined $v and defined( my $src = $args[ $i++ ] )) {
         my $class = blessed $src;

         $v = $class ? ($src->can( $k ) ? $src->$k() : undef) : $src->{ $k };
      }

      defined $v and $dest->{ $k } = $v;
   }

   return $dest;
}

sub my_prefix (;$) {
   return split_on__( basename( $_[ 0 ] // q(), PERL_EXTNS ) );
}

sub nonblocking_write_pipe_pair () {
   my ($r, $w); pipe $r, $w or throw( 'No pipe' );

   fcntl $w, F_SETFL, O_NONBLOCK; $w->autoflush( 1 );

   binmode $r; binmode $w;

   return [ $r, $w ];
}

sub ns_environment ($$;$) {
   my ($class, $k, $v) = @_; $k = (env_prefix $class).'_'.(uc $k);

   return defined $v ? $ENV{ $k } = $v : $ENV{ $k };
}

sub pad ($$;$$) {
   my ($v, $wanted, $str, $direction) = @_; my $len = $wanted - length $v;

   $len > 0 or return $v; (defined $str and length $str) or $str = q( );

   my $pad = substr( $str x $len, 0, $len );

   (not $direction or $direction eq 'right') and return $v.$pad;
   $direction eq 'left' and return $pad.$v;

   return (substr $pad, 0, int( (length $pad) / 2 )).$v
         .(substr $pad, 0, int( 0.99999999 + (length $pad) / 2 ));
}

sub prefix2class (;$) {
   return join '::', map { ucfirst } split m{ - }mx, my_prefix( $_[ 0 ] );
}

sub socket_pair () {
   my $rdr = gensym; my $wtr = gensym;

   socketpair( $rdr, $wtr, AF_UNIX, SOCK_STREAM, PF_UNSPEC )
     or throw( $EXTENDED_OS_ERROR );
   shutdown  ( $rdr, 1 );  # No more writing for reader
   shutdown  ( $wtr, 0 );  # No more reading for writer

   return [ $rdr, $wtr ];
}

sub split_on__ (;$$) {
   return (split m{ _ }mx, $_[ 0 ] // q())[ $_[ 1 ] // 0 ];
}

sub split_on_dash (;$$) {
   return (split m{ \- }mx, $_[ 0 ] // q())[ $_[ 1 ] // 0 ];
}

sub squeeze (;$) {
   (my $v = $_[ 0 ] // q()) =~ s{ \s+ }{ }gmx; return $v;
}

sub strip_leader (;$) {
   (my $v = $_[ 0 ] // q()) =~ s{ \A [^:]+ [:] \s+ }{}msx; return $v;
}

sub sub_name (;$) {
   my $frame = 1 + ($_[ 0 ] // 0);

   return (split m{ :: }mx, ((caller $frame)[ 3 ]) // 'main')[ -1 ];
}

sub symlink (;$$$) {
   my ($from, $to, $base) = @_;

   defined $base and not CORE::length $base and $base = File::Spec->rootdir;
   $from or throw( Unspecified, [ 'path from' ] );
   $from = io( $from )->absolute( $base );
   $from->exists or throw( PathNotFound, [ "${from}" ] );
   $to   or throw( Unspecified, [ 'path to' ] );
   $to   = io( $to   )->absolute( $base ); $to->is_link and $to->unlink;
   $to->exists  and throw( PathAlreadyExists, [ "${to}" ] );
   CORE::symlink "${from}", "${to}"
      or throw( 'Symlink from [_1] to [_2] failed: [_3]',
                [ "${from}", "${to}", $OS_ERROR ] );
   return "Symlinked ${from} to ${to}";
}

sub thread_id () {
   return exists $INC{ 'threads.pm' } ? threads->tid() : 0;
}

sub throw (;@) {
   EXCEPTION_CLASS->throw( @_ );
}

sub throw_on_error (;@) {
   EXCEPTION_CLASS->throw_on_error( @_ );
}

sub trim (;$$) {
   my $chs = $_[ 1 ] // " \t"; (my $v = $_[ 0 ] // q()) =~ s{ \A [$chs]+ }{}mx;

   chomp $v; $v =~ s{ [$chs]+ \z }{}mx; return $v;
}

sub unescape_TT (;$$) {
   my $v  = defined $_[ 0 ] ? $_[ 0 ] : q();
   my $fl = ($_[ 1 ] && $_[ 1 ]->[ 0 ]) || '<';
   my $fr = ($_[ 1 ] && $_[ 1 ]->[ 1 ]) || '>';

   $v =~ s{ ${fl}\% }{[%}gmx; $v =~ s{ \%${fr} }{%]}gmx;

   return $v;
}

sub untaint_cmdline (;$) {
   return untaint_string( UNTAINT_CMDLINE, $_[ 0 ] );
}

sub untaint_identifier (;$) {
   return untaint_string( UNTAINT_IDENTIFIER, $_[ 0 ] );
}

sub untaint_path (;$) {
   return untaint_string( UNTAINT_PATH, $_[ 0 ] );
}

sub untaint_string ($;$) {
   my ($regex, $string) = @_;