Server IP : 195.201.23.43 / Your IP : 3.15.189.95 Web Server : Apache System : Linux webserver2.vercom.be 5.4.0-192-generic #212-Ubuntu SMP Fri Jul 5 09:47:39 UTC 2024 x86_64 User : kdecoratie ( 1041) PHP Version : 7.1.33-63+ubuntu20.04.1+deb.sury.org+1 Disable Function : pcntl_alarm,pcntl_fork,pcntl_waitpid,pcntl_wait,pcntl_wifexited,pcntl_wifstopped,pcntl_wifsignaled,pcntl_wifcontinued,pcntl_wexitstatus,pcntl_wtermsig,pcntl_wstopsig,pcntl_signal,pcntl_signal_get_handler,pcntl_signal_dispatch,pcntl_get_last_error,pcntl_strerror,pcntl_sigprocmask,pcntl_sigwaitinfo,pcntl_sigtimedwait,pcntl_exec,pcntl_getpriority,pcntl_setpriority,pcntl_async_signals, MySQL : OFF | cURL : ON | WGET : ON | Perl : ON | Python : OFF | Sudo : ON | Pkexec : ON Directory : /usr/share/perl5/Specio/ |
Upload File : |
package Specio::PartialDump; use strict; use warnings; our $VERSION = '0.45'; use Scalar::Util qw( looks_like_number reftype blessed ); use Exporter qw( import ); our @EXPORT_OK = qw( partial_dump ); my $MaxLength = 100; my $MaxElements = 6; my $MaxDepth = 2; sub partial_dump { my (@args) = @_; my $dump = _should_dump_as_pairs(@args) ? _dump_as_pairs( 1, @args ) : _dump_as_list( 1, @args ); if ( length($dump) > $MaxLength ) { my $max_length = $MaxLength - 3; $max_length = 0 if $max_length < 0; substr( $dump, $max_length, length($dump) - $max_length ) = '...'; } return $dump; } sub _should_dump_as_pairs { my (@what) = @_; return if @what % 2 != 0; # must be an even list for ( my $i = 0; $i < @what; $i += 2 ) { return if ref $what[$i]; # plain strings are keys } return 1; } sub _dump_as_pairs { my ( $depth, @what ) = @_; my $truncated; if ( defined $MaxElements and ( @what / 2 ) > $MaxElements ) { $truncated = 1; @what = splice( @what, 0, $MaxElements * 2 ); } return join( ', ', _dump_as_pairs_recursive( $depth, @what ), ( $truncated ? "..." : () ) ); } sub _dump_as_pairs_recursive { my ( $depth, @what ) = @_; return unless @what; my ( $key, $value, @rest ) = @what; return ( ( _format_key( $depth, $key ) . ': ' . _format( $depth, $value ) ), _dump_as_pairs_recursive( $depth, @rest ), ); } sub _dump_as_list { my ( $depth, @what ) = @_; my $truncated; if ( @what > $MaxElements ) { $truncated = 1; @what = splice( @what, 0, $MaxElements ); } return join( ', ', ( map { _format( $depth, $_ ) } @what ), ( $truncated ? "..." : () ) ); } sub _format { my ( $depth, $value ) = @_; defined($value) ? ( ref($value) ? ( blessed($value) ? _format_object( $depth, $value ) : _format_ref( $depth, $value ) ) : ( looks_like_number($value) ? _format_number( $depth, $value ) : _format_string( $depth, $value ) ) ) : _format_undef( $depth, $value ), } sub _format_key { my ( undef, $key ) = @_; return $key; } sub _format_ref { my ( $depth, $ref ) = @_; if ( $depth > $MaxDepth ) { return overload::StrVal($ref); } else { my $reftype = reftype($ref); $reftype = 'SCALAR' if $reftype eq 'REF' || $reftype eq 'LVALUE'; my $method = "_format_" . lc $reftype; if ( my $sub = __PACKAGE__->can($method) ) { return $sub->( $depth, $ref ); } else { return overload::StrVal($ref); } } } sub _format_array { my ( $depth, $array ) = @_; my $class = blessed($array) || ''; $class .= "=" if $class; return $class . "[ " . _dump_as_list( $depth + 1, @$array ) . " ]"; } sub _format_hash { my ( $depth, $hash ) = @_; my $class = blessed($hash) || ''; $class .= "=" if $class; return $class . "{ " . _dump_as_pairs( $depth + 1, map { $_ => $hash->{$_} } sort keys %$hash ) . " }"; } sub _format_scalar { my ( $depth, $scalar ) = @_; my $class = blessed($scalar) || ''; $class .= "=" if $class; return $class . "\\" . _format( $depth + 1, $$scalar ); } sub _format_object { my ( $depth, $object ) = @_; return _format_ref( $depth, $object ); } sub _format_string { my ( undef, $str ) = @_; # FIXME use String::Escape ? # remove vertical whitespace $str =~ s/\n/\\n/g; $str =~ s/\r/\\r/g; # reformat nonprintables $str =~ s/(\P{IsPrint})/"\\x{" . sprintf("%x", ord($1)) . "}"/ge; _quote($str); } sub _quote { my ($str) = @_; qq{"$str"}; } sub _format_undef {"undef"} sub _format_number { my ( undef, $value ) = @_; return "$value"; } # ABSTRACT: A partially rear-ended copy of Devel::PartialDump without prereqs 1; __END__ =pod =encoding UTF-8 =head1 NAME Specio::PartialDump - A partially rear-ended copy of Devel::PartialDump without prereqs =head1 VERSION version 0.45 =head1 SYNOPSIS use Specio::PartialDump qw( partial_dump ); partial_dump( { foo => 42 } ); partial_dump(qw( a b c d e f g )); partial_dump( foo => 42, bar => [ 1, 2, 3 ], ); =head1 DESCRIPTION This is a copy of Devel::PartialDump with all the OO bits and prereqs removed. You may want to use this module in your own code to generate nicely formatted messages when a type constraint fails. This module optionally exports one sub, C<partial_dump>. This sub accepts any number of arguments. If given more than one, it will assume that it's either been given a list of key/value pairs (to build a hash) or a list of values (to build an array) and dump them appropriately. Objects and references are stringified in a sane way. =for Pod::Coverage partial_dump =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2008 by יובל קוג'מן (Yuval Kogman). This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 SUPPORT Bugs may be submitted at L<https://github.com/houseabsolute/Specio/issues>. I am also usually active on IRC as 'autarch' on C<irc://irc.perl.org>. =head1 SOURCE The source code repository for Specio can be found at L<https://github.com/houseabsolute/Specio>. =head1 AUTHOR Dave Rolsky <autarch@urth.org> =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2012 - 2019 by Dave Rolsky. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) The full text of the license can be found in the F<LICENSE> file included with this distribution. =cutPrivate