Class-Usul

 view release on metacpan or  search on metacpan

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

   my $name = basename
      ( $_[ 0 ]->inflate_path( $_[ 1 ], 'pathname' ), PERL_EXTNS );

   return (split_on__ $name, 1) || (split_on_dash $name, 1) || $name;
}

sub _build_pathname {
   my $name = ('-' eq substr $PROGRAM_NAME, 0, 1) ? $EXECUTABLE_NAME
                                                  : $PROGRAM_NAME;

   return rel2abs( (split m{ [ ][\-][ ] }mx, $name)[ 0 ] );
}

sub _build_phase {
   my $verdir  = basename( $_[ 0 ]->inflate_path( $_[ 1 ], 'appldir' ) );
   my ($phase) = $verdir =~ m{ \A v \d+ \. \d+ p (\d+) \z }msx;

   return defined $phase ? $phase : PHASE;
}

sub _build_prefix {
   my $appclass = $_[ 0 ]->inflate_symbol( $_[ 1 ], 'appclass' );

   return (split m{ :: }mx, lc $appclass)[ -1 ];
}

sub _build_root {
   my $dir = $_[ 0 ]->inflate_path( $_[ 1 ], 'vardir', 'root' );

   return -d $dir ? $dir : $_[ 0 ]->inflate_path( $_[ 1 ], 'tempdir' );
}

sub _build_rundir {
   my $dir = $_[ 0 ]->inflate_path( $_[ 1 ], 'vardir', 'run' );

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

   -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;
}

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

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 );

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

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);

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

   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' ] );

lib/Class/Usul/Getopt/Usage.pm  view on Meta::CPAN

   return $result ? " $result" : $NUL;
};

my $_assemble_spec = sub {
   my ($length, $spec) = @_;

   my $stripped  = [ Getopt::Long::Descriptive->_strip_assignment( $spec ) ];
   my $assign    = $_parse_assignment->( $stripped->[ 1 ] );
   my $plain     = join $SPC, reverse
                   map    { length > 1 ? "--${_}${assign}" : "-${_}${assign}" }
                   split m{ [|] }mx, $stripped->[ 0 ];
   my $pad       = $SPC x ($length - length $plain);
   my $highlight = $USAGE_CONF->{highlight} // 'bold';

   $highlight eq 'none' and return $plain.$pad; # Old behaviour

   $assign = color( $highlight ).$assign.color( 'reset' );

   my $markedup  = join $SPC, reverse
                   map    { length > 1 ? "--${_}${assign}" : "-${_}${assign}" }
                   split m{ [|] }mx, $stripped->[ 0 ];

   return $markedup.$pad; # Prefered behaviour works well with short types
};

my $_option_length = sub {
   my $fullspec         = shift;
   my $number_opts      = 1;
   my $last_pos         = 0;
   my $number_shortopts = 0;
   my ($spec, $assign)

lib/Class/Usul/IPC/Cmd.pm  view on Meta::CPAN

      $err eq 'out'    and ${ $filtered } .= $buf;
      $err ne 'null'   and ${ $standard } .= $buf;
      $err eq 'stderr' and emit_to \*STDERR, $buf;
      return;
   }
};

my $_filter_out = sub {
   return join "\n", map    { strip_leader $_ }
                     grep   { not m{ (?: Started | Finished ) }msx }
                     split m{ [\n] }msx, $_[ 0 ];
};

my $_four_nonblocking_pipe_pairs = sub {
   return [ nonblocking_write_pipe_pair, nonblocking_write_pipe_pair,
            nonblocking_write_pipe_pair, nonblocking_write_pipe_pair ];
};

my $_has_shell_meta = sub {
   return (is_arrayref $_[ 0 ] && is_member '|',  $_[ 0 ]) ? TRUE
        : (is_arrayref $_[ 0 ] && is_member '&&', $_[ 0 ]) ? TRUE

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

# Class attributes
my $domain_cache = {}; my $locale_cache = {};

# Private methods
my $_extract_lang_from = sub {
   my ($self, $locale) = @_;

   exists $locale_cache->{ $locale } and return $locale_cache->{ $locale };

   my $sep  = $self->use_country ? '.' : '_';
   my $lang = (split m{ \Q$sep\E }msx, $locale.$sep )[ 0 ];

   return $locale_cache->{ $locale } = $lang;
};

my $_load_domains = sub {
   my ($self, $args) = @_; my $charset;

   assert $self, sub { $args->{locale} }, 'No locale id';

   my $locale = $args->{locale} or return;

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

      'exists_user'     => "select 1 from pg_user where usename = '[_2]';",
      '-execute_ddl'    => 'PGPASSWORD=[_3] '
                         . 'psql -h [_1] -q -t -U [_2] -w -c "[_4]"',
      '-no_pipe'        => TRUE, },
   'sqlite'             => {
      '-execute_ddl'    => "sqlite3 [_6] '[_4]'",
      '-no_pipe'        => TRUE,
      '-qualify_db'     => $_qualify_database_path, }, } };

has 'driver'            => is => 'rwp',  isa => NonEmptySimpleStr,
   builder              => sub { (split m{ [:] }mx, $_[ 0 ]->dsn)[ 1 ] },
   lazy                 => TRUE, trigger => $_rebuild_dsn;

has 'dsn'               => is => 'rwp',  isa => NonEmptySimpleStr,
   builder              => sub { $_[ 0 ]->$_connect_info->[ 0 ] },
   lazy                 => TRUE;

has 'host'              => is => 'rwp',  isa => Maybe[SimpleStr],
   builder              => sub { $_[ 0 ]->$_extract_from_dsn( 'host' ) },
   lazy                 => TRUE, trigger => $_rebuild_dsn;

lib/Class/Usul/TraitFor/OutputLogging.pm  view on Meta::CPAN

      $text = autoformat $text, { right => $width - 1 - length $leader };
   }

   return join "\n", map { (m{ \A $leader }mx ? NUL : $leader).$_ }
                     split  m{ \n }mx, $text;
}

sub error {
   my ($self, $text, $opts) = @_; $text = $self->$_loc( $text, $opts );

   $self->log->error( $_ ) for (split m{ \n }mx, "${text}");

   emit_err $self->add_leader( $text, $opts );

   return TRUE;
}

sub fatal {
   my ($self, $text, $opts) = @_; my (undef, $file, $line) = caller 0;

   my $posn = ' at '.abs_path( $file )." line ${line}";

   $text = $self->$_loc( $text, $opts ).$posn;

   $self->log->alert( $_ ) for (split m{ \n }mx, $text);

   emit_err $self->add_leader( $text, $opts );

   exit FAILED;
}

sub info {
   my ($self, $text, $opts) = @_;

   $opts //= {}; $text = $self->$_loc( $text, $opts, TRUE );

   $self->log->info( $_ ) for (split m{ [\n] }mx, $text);

   $self->quiet or $opts->{quiet} or emit $self->add_leader( $text, $opts );

   return TRUE;
}

sub loc {
   my $self = shift; return $self->l10n->localizer( $self->locale, @_ );
}

lib/Class/Usul/TraitFor/OutputLogging.pm  view on Meta::CPAN

   $v != TRUE and throw 'Cannot turn quiet mode off';

   return $self->_set__quiet_flag( $v );
}

sub warning {
   my ($self, $text, $opts) = @_;

   $opts //= {}; $text = $self->$_loc( $text, $opts );

   $self->log->warn( $_ ) for (split m{ \n }mx, $text);

   $self->quiet or $opts->{quiet} or emit $self->add_leader( $text, $opts );

   return TRUE;
}

1;

__END__

lib/Class/Usul/TraitFor/UntaintedGetopts.pm  view on Meta::CPAN

my $_set_usage_conf = sub { # Should be in describe_options third argument
   return Class::Usul::Getopt::Usage->usage_conf( $_[ 0 ] );
};

my $_split_args = sub {
   my $splitters = shift; my @new_argv;

   for (my $i = 0, my $nargvs = @ARGV; $i < $nargvs; $i++) { # Parse all argv
      my $arg = $ARGV[ $i ];

      my ($name, $value) = split m{ [=] }mx, $arg, 2; $name =~ s{ \A --? }{}mx;

      if (my $splitter = $splitters->{ $name }) {
         $value //= $ARGV[ ++$i ];

         for my $subval (map { s{ \A [\'\"] | [\'\"] \z }{}gmx; $_ }
                         $splitter->records( $value )) {
            push @new_argv, "--${name}", $subval;
         }
      }
      else { push @new_argv, $arg }

lib/Class/Usul/TraitFor/Usage.pm  view on Meta::CPAN

   autoflush STDOUT TRUE; autoflush STDERR TRUE;
   return;
};

my $_get_classes_and_roles = sub {
   my $self = shift; my %uniq = (); ensure_class_loaded 'mro';

   my @classes = @{ mro::get_linear_isa( blessed $self ) };

   while (my $class = shift @classes) {
      $class = (split m{ __WITH__ }mx, $class)[ 0 ];
      $class =~ m{ ::_BASE \z }mx and next;
      $class =~ s{ \A Role::Tiny::_COMPOSABLE:: }{}mx;
      $uniq{ $class } and next; $uniq{ $class }++;

      exists $Role::Tiny::APPLIED_TO{ $class }
         and push @classes, keys %{ $Role::Tiny::APPLIED_TO{ $class } };
   }

   return [ sort keys %uniq ];
};