view release on metacpan or  search on metacpan

lib/DBIO/Util.pm  view on Meta::CPAN

package DBIO::Util;
# ABSTRACT: Internal utility functions for DBIO

use warnings;
use strict;

use Config;

# All configuration as lowercase functions — safe in quote_sub/eval contexts
# when called fully qualified (DBIO::Util::func_name())
sub spurious_version_check_warnings () {
  ( $ENV{DBIO_TEST_VERSION_WARNS_INDISCRIMINATELY} || $] < 5.010 ) ? 1 : 0
}
sub is_windows ()      { $^O eq 'MSWin32' ? 1 : 0 }
sub is_dev_release ()  { ($DBIO::VERSION || '') =~ /_/ ? 1 : 0 }
sub old_mro ()         { $] < 5.009_005 ? 1 : 0 }
sub has_ithreads ()    { $Config{useithreads} ? 1 : 0 }
sub unstable_dollar_at () { "$]" < 5.013002 ? 1 : 0 }
sub dbiotest ()        { $INC{"DBIO/Test.pm"} ? 1 : 0 }
sub peepeeness ()      { $INC{"DBIO/Test.pm"} && eval { DBIO::Test->is_smoker } && ($] >= 5.013005 and $] <= 5.013006) }
sub shuffle_unordered_resultsets () { $ENV{DBIO_SHUFFLE_UNORDERED_RESULTSETS} ? 1 : 0 }
sub assert_no_internal_wantarray () { $ENV{DBIO_ASSERT_NO_INTERNAL_WANTARRAY} ? 1 : 0 }
sub assert_no_internal_indirect_calls () { $ENV{DBIO_ASSERT_NO_INTERNAL_INDIRECT_CALLS} ? 1 : 0 }
sub stresstest_utf8_upgrade_generated_collapser_source () { $ENV{DBIO_STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE} ? 1 : 0 }
sub iv_size ()         { $Config{ivsize} }
sub os_name ()         { $^O }
sub help_url ()        { 'https://codeberg.org/dbio/dbio/issues' }

BEGIN {
  if ($] < 5.009_005) {
    require MRO::Compat;
  }
  else {
    require mro;
  }
}

# FIXME - this is not supposed to be here
# Carp::Skip to the rescue soon
use DBIO::Carp '^DBIO';

use B ();
use Carp 'croak';
use Storable 'nfreeze';
use Scalar::Util qw(weaken blessed reftype refaddr);
use Sub::Quote qw(qsub quote_sub);

use base 'Exporter';
our @EXPORT_OK = qw(
  sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt
  fail_on_internal_wantarray fail_on_internal_call
  refdesc refcount hrefaddr
  scope_guard is_exception emit_loud_diag
  quote_sub qsub perlstring serialize dump_value
  UNRESOLVABLE_CONDITION
  dir_path file_path parent_dir slurp_file slurp_file_utf8 write_file mkpath rmtree
  split_name dumper_squashed eval_package_without_redefine_warnings class_path
  firstidx uniq apply array_eq
  foreignbuildargs is_access_broker
  is_windows is_dev_release old_mro help_url unstable_dollar_at
  has_ithreads dbiotest peepeeness shuffle_unordered_resultsets
  iv_size os_name spurious_version_check_warnings
  is_plain_value is_literal_value
  assert_no_internal_wantarray assert_no_internal_indirect_calls
  stresstest_utf8_upgrade_generated_collapser_source
);

use constant UNRESOLVABLE_CONDITION => \ '1 = 0';

sub sigwarn_silencer ($) {
  my $pattern = shift;

  croak "Expecting a regexp" if ref $pattern ne 'Regexp';

  my $orig_sig_warn = $SIG{__WARN__} || sub { CORE::warn(@_) };

  return sub { &$orig_sig_warn unless $_[0] =~ $pattern };
}

sub perlstring ($) { q{"}. quotemeta( shift ). q{"} };

sub hrefaddr ($) { sprintf '0x%x', &refaddr||0 }

sub refdesc ($) {
  croak "Expecting a reference" if ! length ref $_[0];

  # be careful not to trigger stringification,
  # reuse @_ as a scratch-pad
  sprintf '%s%s(0x%x)',
    ( defined( $_[1] = blessed $_[0]) ? "$_[1]=" : '' ),
    reftype $_[0],
    refaddr($_[0]),
  ;
}

sub refcount ($) {
  croak "Expecting a reference" if ! length ref $_[0];

  # No tempvars - must operate on $_[0], otherwise the pad
  # will count as an extra ref
  B::svref_2object($_[0])->REFCNT;
}

sub serialize ($) {
  local $Storable::canonical = 1;

lib/DBIO/Util.pm  view on Meta::CPAN

  local $@;
  eval { $mod->VERSION($ver) } ? 1 : 0;
}

sub modver_gt_or_eq_and_lt ($$$) {
  my ($mod, $v_ge, $v_lt) = @_;

  croak "Nonsensical maximum version supplied"
    if ! defined $v_lt or $v_lt =~ /[^0-9\.\_]/;

  return (
    modver_gt_or_eq($mod, $v_ge)
      and
    ! modver_gt_or_eq($mod, $v_lt)
  ) ? 1 : 0;
}

{
  my $list_ctx_ok_stack_marker;

  sub fail_on_internal_wantarray () {
    return if $list_ctx_ok_stack_marker;

    if (! defined wantarray) {
      croak('fail_on_internal_wantarray() needs a tempvar to save the stack marker guard');
    }

    my $cf = 1;
    while ( ( (caller($cf+1))[3] || '' ) =~ / :: (?:

      # these are public API parts that alter behavior on wantarray
      search | search_related | slice | search_literal

        |

    ) $/x ) {
      $cf++;
    }

    my ($fr, $want, $argdesc);
    {
      package DB;
      $fr = [ caller($cf) ];
      $want = ( caller($cf-1) )[5];
      $argdesc = ref $DB::args[0]
        ? DBIO::Util::refdesc($DB::args[0])
        : 'non '
      ;
    };

    if (
      $want and $fr->[0] =~ /^(?:DBIO|DBICx::)/
    ) {
      DBIO::Exception->throw( sprintf (
        "Improper use of %s instance in list context at %s line %d\n\n    Stacktrace starts",
        $argdesc, @{$fr}[1,2]
      ), 'with_stacktrace');
    }

    my $mark = [];
    weaken ( $list_ctx_ok_stack_marker = $mark );
    $mark;
  }
}

# --- Path helpers (replace Path::Class with core modules) ---

require File::Spec;
require File::Basename;

sub dir_path  { File::Spec->catdir(@_) }
sub file_path { File::Spec->catfile(@_) }
sub parent_dir { File::Basename::dirname($_[0]) }

sub slurp_file {
  open my $fh, '<', $_[0] or croak "Cannot read $_[0]: $!";
  local $/;
  <$fh>;
}

sub mkpath {
  require File::Path;
  File::Path::mkpath([@_]);
}

sub rmtree {
  require File::Path;
  File::Path::rmtree([@_]);
}

# --- End path helpers ---

# --- Loader utilities (merged from DBIO::Loader::Utils) ---

sub split_name {
  require String::CamelCase;
  my ($name, $v) = @_;
  my $BY_NON_ALPHANUM = qr/[\W_]+/;
  if ((not $v) || $v >= 8) {
    return map split($BY_NON_ALPHANUM, $_), String::CamelCase::wordsplit($name);
  }
  my $BY_CASE_TRANSITION_V7 = qr/(?<=[[:lower:]\d])[\W_]*(?=[[:upper:]])|[\W_]+/;
  my $is_camel_case = $name =~ /[[:upper:]]/ && $name =~ /[[:lower:]]/;
  return split $is_camel_case ? $BY_CASE_TRANSITION_V7 : $BY_NON_ALPHANUM, $name;
}

sub dumper_squashed {
  require Data::Dumper;
  my $dd = Data::Dumper->new([]);
  $dd->Terse(1)->Indent(0)->Useqq(1)->Deparse(1)->Quotekeys(0)->Sortkeys(1);
  return $dd->Values([ $_[0] ])->Dump;
}

sub eval_package_without_redefine_warnings {
  my ($pkg, $code) = @_;
  local $SIG{__WARN__} = sigwarn_silencer(qr/^Subroutine \S+ redefined/);
  my @delete_syms;
  my $try_again = 1;
  while ($try_again) {
    eval $code;
    if (my ($sym) = $@ =~ /^Subroutine (\S+) redefined/) {