view release on metacpan or  search on metacpan

t/scan/utf8.t  view on Meta::CPAN

										sub ($$) { substr($_[0],0,5) eq 'HASH('			&& 
																								'{'.sw(ellipsis).'}'.q{%.0s}	},
										sub ($$) { substr($_[0],0,6) eq 'ARRAY('		&& 
																								'['.sw(ellipsis).']'.q{%.0s}	},
										#	sub ($$) { $mxstr && length ($_[0])>$mxstr 
										#						&& qq("%.${mxstr}s")},
										sub ($$) { 1																&& q{"%s"}} ];

			do { $fmt = $_->($v, $ro) and last } for @$given;
			return sprintf($fmt, $v);
		} else { 
			my $pkg = '';
			($pkg, $ref) = ($1, $2) if 0 <= (index $v,'=') && $v=~m{([\w:]+)=(\w+)}; 
			local * nonrefs_b4_refs ;
			* nonrefs_b4_refs = sub {
				ref $v->{$a} cmp ref $v->{$b}  || $a cmp $b 
			};

			local (*IO_glob, *NIO_glob, *IO_io, *NIO_io);
			(*IO_glob, *NIO_glob, *IO_io, *NIO_io) = (
						sub(){'<*'.<$v>.'>'}, sub(){'<*='.$p->Px($v, $lvl-1).'>'},
						sub(){'<='.<$v>.'>'}, sub(){'<|'.$p->Px($v, $lvl-1).'|>'},
					);
			no strict 'refs';
			my %actions = ( 
				GLOB	=>	($p->{implicit_io}? *IO_glob: *NIO_glob),
				IO		=>	($p->{implicit_io}? *IO_io	 : *NIO_io),
				REF		=>	sub(){ "\\" . $p->Px($$_, $lvl-1) . ' '},
				SCALAR=>	sub(){ $pkg.'\\' . $p->Px($$_, $lvl).' ' },
				ARRAY	=>	sub(){ $pkg."[". 
												(join ', ', 
#	not working: why?			#reduce \&rm_adjacent, (commented out)
												map{ $p->Px($_, $lvl) } @$v ) ."]" },
				HASH	=>	sub(){ $pkg.'{' . ( join ', ', @{[
										map {$p->Px($_, $lvl, 1) . '=>'. $p->Px($v->{$_}, $lvl,0)} 
										sort  nonrefs_b4_refs keys %$v]} ) . '}' },);
			if (my $act=$actions{$ref}) { &$act } 
			else { return "$v" }
		}
	}

	sub get_dflts($) {
		my $p = shift; my $caller = $_[0];
		return $p->{dflts}  if exists $p->{dflts};
		return exists $mod_dflts{$caller} ? $mod_dflts{$caller} : $mod_dflts{""};
	}
			


	sub P(@) {    # 'safen' to string or FH or STDOUT
		local *sw = sub (*) {$dflts->{$_[0]}};
		my $p = ref $_[0] eq 'P' ? shift: bless {};
		$p->{__P_seen}={} unless ref $p->{__P_seen};

		local * unsee_ret  = sub ($) { 
			delete $p->{__P_seen} if exists $p->{__P_seen}; 
			$_[0] };

		my $v = $_[0];
    my $rv = ref $v;
		$dflts = $p->get_dflts((caller)[0]);
		my ($depth, $noquote) = (sw(depth), sw(noquote));
    if (HASH eq $rv) {
			my $params = $v; $v = shift; $rv = ref $v;
			$depth = $params->{depth} if exists $params->{depth};
    }
    if (ARRAY eq $rv ) { $v = shift;
      @_=(@$v, @_); $v=$_[0]; $rv = ref $v }

		my ($fh, $f, $explicit_out);
		if ($rv eq GLOB || $rv eq IO) {
			($fh, $explicit_out) = (shift, 1);
			$v = $_[0]; $rv = ref $v;
		} else { $fh =\*STDOUT }
    
		if (ARRAY eq $rv ) { $v = shift;
      @_=(@$v, @_); $v=$_[0]; $rv = ref $v }
    
		my ($fc, $fmt, @flds, $res)=(1, $_[0]);
		if ($fc) { $f = shift; no warnings;
			$res =  sprintf $f,	map {local $_ = $p->Px($_,$depth,$noquote) } @_ } 
		else { $res = $p->Px(@_)}

		chomp $res;

		my ($nl, $ctx) = ("\n", defined wantarray ? 1 : 0);

		($res, $nl, $ctx) = (substr($res, 0, -1 + length $res), "", 2) if
					ord(substr $res,-1) == NoBrHr;									#"NO_BREAK_HERE"

		if (!$fh && !$ctx) {	#internal consistancy check
			($fh = \*STDERR) and 
				P $fh "Invalid File Handle presented for output, using STDERR";
			($explicit_out, $nl) = (1, "\n") }

		else { return unsee_ret($res) if (!$explicit_out and $ctx==1) }

		no warnings 'utf8';
		print $fh ($res . (!$ctx && (!$\ || $\ ne "\n") ? "\n" : "")  );
		unsee_ret($res);
	};

	sub Pe(@) {
		my $p = shift if ref $_[0];
		return '' unless @_;
		unshift @_, \*STDERR;
		unshift @_, $p if ref $p;
		goto &P 
	}


	#Pe "_dflts=%s", \%_dflts;
	#Pe "mod_dflts{}=%s", $mod_dflts{""};
	#Pe "mod_dflts=%s", \%mod_dflts;

	sub import {
		my ($modname, @args) = @_;
		if (@args) {
			my @others;
			my $caller = (caller)[0];
			if (exists $mod_dflts{$caller}) {
				$dflts = $mod_dflts{$caller};
			} else {
				$dflts = undef;					# indicate no customization to dflts
			}
			my $default = 0;
			my @tags = grep {	if (m{^:(.*)$}) {
													if ($1 eq 'default') { $default = 1; $_ = undef } 
													else { $_ = $1 }
												} else { push @others, $_; undef }
											} @args;
			if (@tags) {
				if ($default) {
					# change global defaults (don't use copy)
					$dflts = $mod_dflts{""};
				} else {
					# if dflts was undef start w/copy of glbl-dflts
					%{$mod_dflts{$caller}} = %{$mod_dflts{""}} unless exists
						$mod_dflts{$caller};
						$dflts=$mod_dflts{$caller}
				}
				for (@tags) {
					my ($tag, $value) = m{^(\w+)(?:=(.+))?$} or 
							die "Tag-format: missing :TAG=VALUE for tag '" . $_ . "'";

					my $chk;
				 	{no warnings; no strict; $chk = eval $types{$tag}->($value) };
					$dflts->{$tag} = $chk;
				}
			}
			$dflts = $mod_dflts{""} unless $dflts;	# set to global if not set
			@_=($modname, @others);
		}
		goto &Xporter::import;
	}




	sub ops($) {
		my $p = shift; my $c=ref $p || $p;
		bless $p = {}, $c unless ref $p;
		my $args = $_[0];
		my $ldflts = $p->get_dflts((caller)[0]);
		%{$p->{dflts}} = %$dflts unless ref $p->{dflts};
		die "ops takes a hash to pass arguments" unless HASH $args;
		$ldflts = $p->{dflts};
		foreach (sort keys %$args) {
			if (exists $ldflts->{$_}) { $ldflts->{$_} = $args->{$_} } 
			else { 
				warn  "Unknown key \"$_\" passed to ops";} 
		}
		$p }
1;}		#value 1 placed at as w/most of my end-of-packages (rt#89054)
TEST

test(<<'TEST'); # MCHE/Mojolicious-Che-0.031/lib/Mojolicious/Che.pm
package Mojolicious::Che;
use Mojo::Base::Che 'Mojolicious';
use Mojo::Log::Che;
use Mojo::Loader qw(load_class);

...

sub хазы { # Хазы из конфига
  my $app = shift;
  my $conf = $app->config;
  my $h = $conf->{'mojo_has'} || $conf->{'mojo'}{'has'} || $conf->{'хазы'};
  map {
    $app->log->debug("Make the app->has('$_')");
    has $_ => $h->{$_};
  } keys %$h;
}
TEST

test(<<'TEST'); # MCHE/Mojolicious-Plugin-RoutesAuthDBI-0.785/lib/Mojolicious/Plugin/RoutesAuthDBI/OAuth2.pm
package Mojolicious::Plugin::RoutesAuthDBI::OAuth2;
use Mojo::Base 'Mojolicious::Controller';
use Mojolicious::Plugin::RoutesAuthDBI::Util qw(json_enc load_class);
...

sub отсоединить {
  my $c = shift;
  my $site_name = $c->stash('site');

  my $site = $c->oauth2->providers->{$site_name}
    or die "No such oauth provider [$site_name]" ;
  
  my $curr_profile = $c->curr_profile;
  
  my $r = $c->_model->detach($site->{id}, $curr_profile->{id},);
  #~ $c->app->log->debug("Убрал авторизацию сайта [$site_name] профиля [$curr_profile->{id}]", $c->dumper($r));
  
  $Init->plugin->model->{Refs}->del($r->{ref_id}, undef, undef);
  
  $c->redirect_to($c->param('redirect') || 'profile');
}
TEST

done_testing;