view release on metacpan or  search on metacpan

lib/Assert/Conditional/Utils.pm  view on Meta::CPAN

{
    commify_and map { "'$_'" } @_;
}

sub quotify_or
    :Export( qw[list] )
{
    commify_or map { "'$_'" } @_;
}

sub quotify_nor
    :Export( qw[list] )
{
    commify_nor map { "'$_'" } @_;
}

sub quotify_but
    :Export( qw[list] )
{
    commify_but map { "'$_'" } @_;
}

sub dump_exports(@)
    :Export( qw[exports] )
{
    my $caller_package = caller;
    dump_package_exports($caller_package, @_);
}

sub dump_package_exports($@)
    :Export( qw[exports] )
{
    my($pkg, @exports) = @_;
    my %tag2aref = do { no strict 'refs'; %{$pkg . "::EXPORT_TAGS"} };
    delete $tag2aref{asserts};
    my %seen; # for the all repetition
    my @taglist = @exports ? @exports : ('all', uca_sort(keys %tag2aref));
    my $errors = 0;
    print "=head2 Export Tags\n\n=over\n\n" if $Pod_Generation;
    for my $tag (@taglist)  {
        next if $seen{$tag}++;
        my $aref = $tag2aref{$tag};
        unless ($aref) {
            print STDERR ":$tag is not an export tag in $pkg.\n";
            $errors++;
            next;
        }
        if ($Pod_Generation) {
            print "=item C<:$tag>\n\n", commify_series(map { "L</$_>" } uca_sort @$aref), ".\n\n";
        }
        else {
            print "Conditional export tag :$tag exports ", commify_series(uca_sort @$aref), ".\n";
        }
    }
    print "=back\n\n" if $Pod_Generation;
    return $errors == 0;
}

#################################################################

sub UCA (_)             :Export( qw[unicode] );
sub UCA1(_)             :Export( qw[unicode] );
sub UCA2(_)             :Export( qw[unicode] );
sub UCA3(_)             :Export( qw[unicode] );
sub UCA4(_)             :Export( qw[unicode] );
sub uca_cmp ($$)        :Export( qw[unicode] );
sub uca1_cmp($$)        :Export( qw[unicode] );
sub uca2_cmp($$)        :Export( qw[unicode] );
sub uca3_cmp($$)        :Export( qw[unicode] );
sub uca4_cmp($$)        :Export( qw[unicode] );

{
    my @Comparitor;

    sub _get_comparitor($) {
        my($level) = @_;
        panic "invalid level $level" unless $level =~ /^[1-4]$/;
        return $Comparitor[$level] if $Comparitor[$level];

        require Unicode::Collate;
        my $class = Unicode::Collate:: ;
        # need to discount the other ones altogether
        my @args = (level => $level); #, variable => "Non-Ignorable");
    #   if ($Opt{locale}) {
    #       require Unicode::Collate::Locale;
    #       $class = Unicode::Collate::Locale:: ;
    #       push @args, locale => $Opt{locale};
    #   }
        my $coll = $class->new(@args);
        $Comparitor[$level] = $coll;
    }

    for my $strength ( 1 .. 4 ) {
        no strict "refs";
        *{ "UCA$strength" } = sub(_) {
            state $coll = _get_comparitor($strength);
            return $coll->getSortKey($_[0]);
        };

        *{ "uca${strength}_cmp" } = sub($$) {
            my($this, $that) = @_;
            "UCA$strength"->($this)
                cmp
            "UCA$strength"->($that)

        };
    }

    no warnings "once";
    *UCA     = \&UCA1;
    *uca_cmp = \&uca1_cmp;
}

sub uca_sort(@)
    :Export( qw[unicode list] )
{
     state $collator = _get_comparitor(4);
     return $collator->sort(@_);
}

{
    sub _uniq {
        my %seen;
        my @out;
        for (@_) { push @out, $_ unless $seen{$_}++ }
        return @out;
    }

    @EXPORT_OK = _uniq(@EXPORT_OK);
    for my $tag (keys %EXPORT_TAGS) {
        my @exports = _uniq @{ $EXPORT_TAGS{$tag} };
        $EXPORT_TAGS{$tag} = [@exports];
    }
}

#################################################################

{   # Private scope for sig mappers

    our %Config;  # constrains in-file lexical visibility
    use  Config;

    my $sig_count      = $Config{sig_size}     || botch_undef;
    my $sig_name_list  = $Config{sig_name}     || botch_undef;
    my $sig_num_list   = $Config{sig_num}      || botch_undef;

    my @sig_nums       = split " ", $sig_num_list;
    my @sig_names      = split " ", $sig_name_list;

    my $have;
    $have =  @sig_nums;
    $have == $sig_count                 || panic "expected $sig_count signums, not $have";

    $have =  @sig_names;
    $have == $sig_count                 || panic "expected $sig_count signames, not $have";

    my(%_Map_num2name, %_Map_name2num);

    @_Map_num2name {@sig_nums } = @sig_names;
    @_Map_name2num {@sig_names} = @sig_nums;

    sub sig_num2name($)
        :Export( sigmappers )
    {
        my($num) = @_;
        $num =~ /^\d+$/                 || botch "$num doesn't look like a signal number";
        return $_Map_num2name{$num}     // botch_undef;
    }

    sub sig_num2longname($)
        :Export( sigmappers )
    {
        return q(SIG) . &sig_num2name;
    }

lib/Assert/Conditional/Utils.pm  view on Meta::CPAN

L</code_of_coderef>, L</commify_and>, L</commify_but>, L</commify_nor>,
L</commify_or>, L</commify_series>, L</dump_exports>,
L</dump_package_exports>, L</FIXME>, L</his_args>, L</his_assert>,
L</his_context>, L</his_filename>, L</his_frame>, L</his_is_require>,
L</his_line>, L</his_package>, L</his_sub>, L</his_subroutine>,
L</name_of_coderef>, L</NOT_REACHED>, L</%N_PLURAL>, L</panic>,
L</%PLURAL>, L</quotify_and>, L</quotify_but>, L</quotify_nor>,
L</quotify_or>, L</sig_name2num>, L</sig_num2longname>, L</sig_num2name>,
L</subname_or_code>, L</UCA>, L</UCA1>, L</uca1_cmp>, L</UCA2>,
L</uca2_cmp>, L</UCA3>, L</uca3_cmp>, L</UCA4>, L</uca4_cmp>,
L</uca_cmp>, and L</uca_sort>.

=item C<:acme_plurals>

L</%N_PLURAL> and L</%PLURAL>.

=item C<:botch>

L</botch>, L</botch_argc>, L</botch_array_length>, L</botch_false>,
L</botch_have_thing_wanted>, L</botch_undef>, and L</panic>.

=item C<:CALLER>

L</CALLER_BITMASK>, L</CALLER_EVALTEXT>, L</CALLER_FILENAME>,
L</CALLER_HASARGS>, L</CALLER_HINTHASH>, L</CALLER_HINTS>,
L</CALLER_IS_REQUIRE>, L</CALLER_LINE>, L</CALLER_PACKAGE>,
L</CALLER_SUBROUTINE>, and L</CALLER_WANTARRAY>.

=item C<:code>

L</code_of_coderef>, L</name_of_coderef>, and L</subname_or_code>.

=item C<:exports>

L</dump_exports> and L</dump_package_exports>.

=item C<:frame>

L</CALLER_BITMASK>, L</CALLER_EVALTEXT>, L</CALLER_FILENAME>,
L</CALLER_HASARGS>, L</CALLER_HINTHASH>, L</CALLER_HINTS>,
L</CALLER_IS_REQUIRE>, L</CALLER_LINE>, L</CALLER_PACKAGE>,
L</CALLER_SUBROUTINE>, L</CALLER_WANTARRAY>, L</his_args>,
L</his_assert>, L</his_context>, L</his_filename>, L</his_frame>,
L</his_is_require>, L</his_line>, L</his_package>, L</his_sub>, and
L</his_subroutine>.

=item C<:lint>

L</FIXME>, L</NOT_REACHED>, and L</panic>.

=item C<:list>

L</commify_and>, L</commify_but>, L</commify_nor>, L</commify_or>,
L</commify_series>, L</quotify_and>, L</quotify_but>, L</quotify_nor>,
L</quotify_or>, and L</uca_sort>.

=item C<:sigmappers>

L</sig_name2num>, L</sig_num2longname>, and L</sig_num2name>.

=item C<:unicode>

L</UCA>, L</UCA1>, L</uca1_cmp>, L</UCA2>, L</uca2_cmp>, L</UCA3>,
L</uca3_cmp>, L</UCA4>, L</uca4_cmp>, L</uca_cmp>, and L</uca_sort>.

=item C<:vars>

L</$Allow_Handlers>, L</$Assert_Always>, L</$Assert_Carp>,
L</$Assert_Debug>, and L</$Assert_Never>.

=back

=head2 Exported Functions

About the only thing here that's "public" is L</botch>
and the C<sig*> name-to-number mapping functions.
The rest are internal and shouldn't be relied on.

=over

=item C<botch($)>

The main way that assertions fail.  Normally it raises an exception
by calling C<Carp::confess>, but this can be controlled using the
C<ASSERT_CONDITIONAL> environment variable or its associated package
variables as previously described.

We crawl up the stack to find the I<highest> function named C<assert_*> to
use for the message. That way when an assertion calls another assertion and that
second one fails, the reported message uses the name of the first one.

=item C<botch_false()>

A way to panic if something is false but shouldn't be.

=item C<botch_undef()>

A way to panic if something is undef but shouldn't be.

=item C<botch_argc($$)>

=item C<botch_array_length($$)>

=item C<botch_have_thing_wanted(@)>

=item C<panic(I<MESSAGE>)>

This function is used for internal errors that should never happen.
It calls C<Carp::confess> with a prefix indicating that it is an
internal error.

=item C<FIXME>

Code you haven't gotten to yet.

=item C<NOT_REACHED>

Put this in places that you think you can never reach in your code.

=item C<his_assert()>