Result:
found more than 108 distributions - search limited to the first 2001 files matching your query ( run in 1.213 )


A1z-HTML5-Template

 view release on metacpan or  search on metacpan

lib/A1z/HTML5/Template.pm  view on Meta::CPAN

); 



sub new {
	my $class = shift;
	my $self  = bless { @_ }, $class;
	return $self;
}


sub math1 
{
	my $self = shift; 
	
	my ($num1, $num2) = @_;
	
	if ($num1 eq '') { $num1 = '2'; }
	if ($num2 eq '') { $num2 = '4'; }
	
	my $out;
	
	my $m = $num1 * $num2;
	my $a  = $num1 + $num2;
	my $s  = $num1 - $num2;
	my $s1 = $num2 - $num1;
	my $d = $num1 / $num2;
	my $d1 = $num2 / $num1;
	
	$out .= qq{<div class="math">
	<table class="table table-responsive table-bordered table-condensed table-hover">
	
		<thead><tr><td colspan="6">Multiplication</td></tr></thead>
		<tr> 
			<td></td>
			<td>$num1</td> 
			<td>x</td> 
			<td>$num2</td> 
			<td>\=</td> 
			<td>$m</td> 
		</tr>
	
		<thead><tr><td colspan="6">Addition</td></tr></thead> 
		<tr> <td></td> <td>$num1 </td> <td>\+</td> <td> $num2</td> <td> \=</td> <td> $a</td> </tr>
		
		<thead><tr><td colspan="6">Subtraction</td></tr></thead>
		<tr> <td></td> <td>$num1</td> <td> \-</td> <td> $num2</td> <td> \=</td> <td> $s</td> </tr>
		<tr> <td></td> <td>$num2</td> <td> \-</td> <td> $num1</td> <td> \=</td> <td> $s1</td> </tr>
		
		<thead><tr><td colspan="6">Division</td></tr></thead>
		<tr> <td></td> <td>$num1</td> <td> \/</td> <td> $num2</td> <td> \=</td> <td> $d </td></tr>
		<tr> <td></td> <td>$num2</td> <td> \/</td> <td> $num1</td> <td> \=</td> <td> $d1</td> </tr>
		
	</table>
	</div>
	};

	return qq{\n$out\n};
}



# begin timestable 
sub timestable 
{	
	my $self = shift;
	
	my ($num1) = @_;
	
	if ( $num1 eq '' ) { $num1 = '2'; }
	
	my $out;
	
	$out .= qq{<table class="table table-bordered table-condensed table-striped table-hover table-responsive">};
	
	for ('1'..'20') 
	{
		$out .= qq{<tr> <td>$num1</td> <td>x</td> <td>$_</td> <td>=</td> <td>} . $num1 * $_ . qq{</td></tr>} if ($_);
	}
	$out .= qq{</table>};
	
	return $out;
}
# end timestable 



# begin header 
sub header 
{
	my $self = shift; 
	
	my @keys; 
	if (@_) { @keys = @_; } 
	
	my $args = scalar(@keys); 
	
	my ($key, $key1) = @_;
	
	my %out;
	
	if ($ARGV and $ARGV > 0 and scalar(@keys) > 0) 
	{
		if ($key eq 'utf8')
		{
			$out{"$key"} = qq{Content-Type: text/html;charset=utf-8\n\n}; 
			
		} 
		elsif (!defined $key or $key eq '') 
		{
			$out{"$key"} = qq{Content-Type: text/html;charset=utf-8\n\n};
		}
		else 
		{
			$out{"$key"} = qq{Content-Type: text/html;charset=utf-8\n\n};
		}
	}
	else 
	{
		return qq{Content-Type: text/html;charset=utf-8\n\n}; 
	}
	
} 
# end header 



# begin start html 01
sub start_html  
{ 
	my $self = shift;
	
	my @keys; 
	if (@_) { @keys = @_; } 
	
	my $args = scalar @keys; 
	
	my ($key, $key1) = @_; 
	
	my %out; 
	
	if ($args and $args >= 0) 
	{
		# have your own custom header, backwards compatibility 
		
		my $out; 
		
		$out .= qq{@_ }; 
		
		return $out; 
		
	}
	else 
	{
		my $out; 
		
		$out .= qq{<!DOCTYPE html>\n<html>\n};  
		$out .= qq{<head>\n}; 
	
		return $out; 
		
	}
} 
# end start_html 




sub body_js_css 
{
	my $self = shift;
	
	my $key = "@_"; 
	
	my @keys; 
	if (@_) { @keys = @_; } 
	
	my $args = scalar (@keys); 
	
	my $out; 
	
	$out .= qq^
		<!--jquery-->
		<script src="https://code.jquery.com/jquery-1.12.4.min.js"></script>
		<!--bootstrap/jQueryUI-->
		<script src="https://maxcdn.bootstrapcdn.com/bootstrap/3.3.0/js/bootstrap.min.js"></script>
		<script src="https://code.jquery.com/ui/1.11.4/jquery-ui.min.js"></script>

		<!-- IE10 viewport hack for Surface/desktop Windows 8 bug -->
		<script  src="https://www.a1z.us/jquery/bootstrap/fixed-top/ie10-viewport-bug-workaround.js"></script>

		<script>
		
		// for tabs 
		\$( function() {
			var tabs = \$("#tabs").tabs();
			tabs.find( ".ui-tabs-nav" ).sortable({
				axis: "x",
				stop: function() { tabs.tabs( "refresh" ); }
			});
		}); 
		  
		// dialog 
		\$( function() {
			\$( "#dialog" ).dialog({
			  autoOpen: false,
			  show: {
				effect: "blind",
				duration: 1000
			  },
			  hide: {
				effect: "explode",
				duration: 1000
			  }
			});
		 
			\$( "#opener" ).click(function() {
			  \$( "#dialog" ).dialog( "open" );
			});
		});
		  
		\$('#menu').menu(); 
		\$('#accordion').accordion(); 
		\$('#accordion1').accordion(); 
		\$('#accordion2').accordion(); 
		\$('#accordion3').accordion(); 
		\$('#tabs').tabs(); 
		
		</script>
	
	^; 
	
	
	if ( $args ) 
	{
		
		if ( $args >= 0) 
		{
			my $return;
			
			for (@keys ) 
			{
				chomp;
				if ($_ =~ /.js$/)
				{
					$return .= qq{<script  src="$_"></script>\n}; 
				}
				elsif ($_ =~ /.css$/)
				{
					$return .= qq{<link href="$_" rel="stylesheet" style="text/css">\n}; 
				}
				else 
				{
					# do nothing
				}
			}
			
			return qq{$return}; 	#
		}
		else 
		{
			return qq{$out}; 
		}
		
	}
	else 
	{
		return qq{<!--229 noParams-->$out}; 	# 
	} 
	
}





# start end_html 
sub end_html 
{ 
	my $self = shift;
	
	my @keys; 
	if (@_) { @keys = @_; } 
	
	my ($key, $key1) = @_;
	
	my $out; 
		
	$out .= qq{</html>\n\n};
	
	if ($ARGV and $ARGV > 0 or scalar(@keys) > 0) 
	{
		return qq{@_};
	}
	else 
	{	
		return $out; 
	}
} 
# end end_html




# start head title 02 
sub head_title
{
	my $self = shift;
	
	my $key = "@_"; 
	
	my @keys; 
	if (@_) { @keys = @_; } 
	
	my $out; 
	
	$out .= qq{}; 
	
	if ($ARGV and $ARGV > 0 or scalar(@keys) > 0) 
	{
		
		if ($key) 
		{
			return qq{<title>@_</title>\n}; 
		}
		else 
		{
			return qq{<title>Template</title>\n}; 
		}
		
	}
	else 
	{
		return qq{<title>Package Html5</title>\n}; 	# this works but does not ask the user
	}
	
} 
# end head title 




# begin head meta 03
sub head_meta
{
	my $self = shift;
	
	my $key = "@_"; 
	
	my @keys; 
	if (@_) { @keys = @_; } 
	
	my $args = scalar @keys; 
	
	my $out; 
	
	$out .= qq{<meta charset="utf-8">
<meta lang="en">
<meta http-equiv="X-UA-Compatible" content="IE=edge"> 
<meta name="HandheldFriendly" content="true"> 
<meta name="viewport" content="width=device-width, initial-scale=1"> 
}; 
	
	if ($args) 
	{
		
		if ($args >= 0) 
		{
			my $return;
			
			for (@keys ) 
			{
				chomp;
				
				my ( $meta_name, $meta_cont) = split(/---/, $_, 2);
				
				$return .= qq{<meta name="$meta_name" content="$meta_cont">\n}; 
			}
			
			return qq{$return<!--360-->}; 
		}
		else 
		{
			$out .= qq{<meta name="description" content="HTML5 by Business Impact Solutions - bislinks.com"/><!--364-->}; 
			# add default meta if user has not called one of his own
			return qq{$out}; 
		}
		
	}
	else 
	{
		return qq{$out}; 	# this works but does not ask the user
	}
	
} 
# end head meta 03 




# begin body top nav bar
sub body_topnavbar
{
	my $self = shift;
	
	my %in;
	
	%in = (
		file => "https://www.a1z.us/js/utils/top-nav-bar.js",
		name => "Menu",
		@_,
	);
	
	my $out; 
	
	$out .= qq{<!--top nav bar begin-->
<script src="$in{file}"></script>
<script>
	fixed_top_navbar('', '', '$in{name}', '', '');
</script>
<!-- top nav bar end--> 
}; 
	
	return qq{$out\n}; 	# this works but does not ask the user
	
} 
# end body top nav bar




sub head_js_css
{
	my $self = shift;
	
	my $key = "@_"; 
	
	my @keys; 
	if (@_) { @keys = @_; } 
	
	my $args = scalar (@keys); 
	
	my $out; 
	
	$out .= qq{
	
	<!-- Bootstrap/jqueryUI -->

	<link href="https://maxcdn.bootstrapcdn.com/bootstrap/3.3.0/css/bootstrap.min.css" rel="stylesheet" type="text/css">
	<link href="https://www.a1z.us/jquery/bootstrap/fixed-top/navbar-fixed-top.css" rel="stylesheet">
	<link href="https://code.jquery.com/ui/1.12.1/themes/smoothness/jquery-ui.css" rel="stylesheet">

	<!--HTML5 shim and Respond.js for IE8 support of HTML5 elements and media queries-->

	<!--[if lt IE 9]>
	<script src="https://oss.maxcdn.com/html5shiv/3.7.2/html5shiv.min.js"></script>
	<script src="https://oss.maxcdn.com/respond/1.4.2/respond.min.js"></script>
	<![endif]-->

}; 
	
	if ($args) 
	{
		
		if ($args >= 0) 
		{
			my $return;
			
			for (@keys) 
			{
				chomp;
				if ($_ =~ /.js$/)
				{
					$return .= qq{<!--442--> \n<script  src="$_"></script> \n}; 
				}
				elsif ($_ =~ /.css$/)
				{
					$return .= qq{<!--446--> \n<link href="$_" rel="stylesheet" style="text/css"> \n}; 
				}
				else 
				{
					# do nothing
					return qq{@keys<!--469-->\n}; 
				}
			}
			
			return qq{$return<!--473 jQ-->\n}; 
		}
		else 
		{
			return qq{$out\n}; 
		}
		
	}
	else 
	{
		return qq{$out\n}; 	# this works but does not ask the user
	}
	
} 
# end head js css




# begin end head
sub end_head 
{ 
	my $self = shift;
	
	my $key = "@_"; 
	
	my @keys; 
	if (@_) { @keys = @_; } 
	
	my $out; 
	
	$out .= qq{</head>}; 
	
	if ($ARGV and $ARGV > 0 or scalar(@keys) > 0) 
	{
		
		if (@_) 
		{
			return qq{@_\n}; 
		}
		else 
		{
			return qq{$out\n}; 
		}
		
	}
	else 
	{
		return qq{$out\n}; 	# this works but does not ask the user
	}
} 
# end end head 



# begin begin body 
sub begin_body 
{ 
	my $self = shift;
	
	my $key = "@_"; 
	
	my @keys;  
	if (@_) { @keys = @_; } 
	
	my $out; 
	
	$out .= qq{<body>}; 
	
	if ($ARGV and $ARGV > 0 or scalar(@keys) > 0) 
	{
		
		if (@_) 
		{
			return qq{@_\n}; 
		}
		else 
		{
			return qq{$out\n}; 
		}
		
	}
	else 
	{
		return qq{$out\n}; 	# this works but does not ask the user
	}
} 
# end begin body



# begin accordion or rather file content.  Need to change name of this method
sub body_accordion 
{
	my $self = shift;
	
	my $key = "@_"; 
	
	my @keys;  
	if (@_) { @keys = @_; } 
	
	my $out; 
	
	$out .= qq{<!--begin Content--> 
<div id="accordion617" class="accordion">
	<h3>Who is it for</h3>
	<div>For those who know/uderstand Perl/HTML/jQuery</div>
	<h3>What about a bigger number?</h3>
	<div>Sure.  Use the custom form to get the times table for a number greater than 30?</div>
	<h3>How about any number/range?</h3>
	<div>Yes, of course!  Once again, use the custom form bearing the heading "Or enter your own"</div>
	<h3>Can I customize it for own use?</h3>
	<div>In that case, you need to purchase the software and/or order a customization</div>
</div>

<!--end Content-->

}; 
	
	if ($ARGV and $ARGV > 0 or scalar(@keys) > 0) 
	{
		
		if (@_) 
		{
			return qq{\n@_\n}; 
		}
		else 
		{
			return qq{\n$out\n}; 
		}
		
	}
	else 
	{
		return qq{\n$out\n}; 	#
	}
} 
# end accordion




sub body_article 
{  
	my $self = shift;
	
	my $out;
	
	my %in;
	%in = 
	(
		content => "",
		type => "article",
		header => "Content Header",
		@_,
	);
	
	if ( !defined $in{content} or $in{content} eq '' )
	{
		return qq{
			No Content
		};
	}
	else
	{
		return qq{<article class="container"><h2>$in{header}</h2>
			$in{content}
		</article>
		};
	}
}




# begin begin body 
sub end_body 
{ 
	my $self = shift;
	
	my $key = "@_"; 
	
	my @keys;  
	if (@_) { @keys = @_; } 
	
	my $out; 
	
	$out .= qq{\n</body>\n}; 
	
	if ($ARGV and $ARGV > 0 or scalar(@keys) > 0) 
	{
		
		if (@_) 
		{
			return qq{@_\n}; 
		}
		else 
		{
			return qq{$out\n}; 
		}
		
	}
	else 
	{
		return qq{$out\n}; 	# this works but does not ask the user
	}
} 
# end end body





# begin content folder to select form 
sub body_form 
{
	my $self = shift; 
	
	my $out; 
	
	my @keys;  
	if (@_) { @keys = @_; } 
	
	my ($vars, $vals) = (''); 
	for (@keys) 
	{
		$vars = $_ if ($_ =~ /^vars/); 

		# $vals not used
		$vals = $_ if ($_ =~ /^vals/); 
	}
	
	my @form_vars = split(/\;/, $vars); 
	
	my @form_vals = split(/\;/, $vals); 
	
	# get params for hidden fields if given 
	my @hidden; 
	if ($form_vars[4] and $form_vars[4] =~ /\,/) 
	{
		 @hidden = split(/\,/, $form_vars[4]); 
	}
	else 
	{
		@hidden = ("No", "Vals"); 
	}
	
	# if SELECT .... 
	
	my $select; 
	
	if ($form_vars[3] and $form_vars[3] =~ /^select/) 
	{
		# get the params for the form 
		#   select,   
		my ($sel_key, $sel_name, $sel_default, $folder_or_file, $selectLabelText) = split(/\,/, $form_vars[3], 5); 

		$select .= qq{
	<label for="$sel_name">$selectLabelText</label>
	<div class="form-group"><!--begin select-->
	\t<select name="$sel_name">
	\t\t<option selected value="$sel_default">$sel_default</option>
	};
		
		#now open file/folder to fill "options" 
		if ( -f $folder_or_file ) 
		{
			# open as file 
			#$select .= qq{none}; 
		}
		elsif (-d $folder_or_file)
		{
			# open as dir and add all files in it to "options" 
			opendir(D, "$folder_or_file") or $select .= qq{<div class="error">$!</div>};
			my @DIR = readdir(D);
			
			while ( my $file = <each @DIR> )
			{
				# only if file contains alphabets, numbers, and dashes 
				next unless $file =~ /[a-zA-Z0-9\-]/; 

				# comment if you want subfolders also listed 
				next unless -f "$folder_or_file/$file"; 

				# get rid of . and ..
				next if $file =~ /^(\.|\.\.)/; 

				# do not add hidden files to the options list
				next if $file =~ /^\./; 
				
				# get the size of th file 
				my $size = -s "$folder_or_file/$file"; 
				my $original = $size; 
					$size /= 1024; 
					#$size /= 1024;
					$size = sprintf "%.2f", $size; 
				$select .= qq{\n\t\t\t<option value="$file">$file [$size kb]</option>} if $file; 
			}

			close D;
		}

		$select .= qq{\n\t\t</select>\n\t</div>\n}; 
	}
	else 
	{
		# no select
		$select .= qq{}; 
	}
	 
	
	$out .= qq{<form action="$form_vars[2]" method="$form_vars[1]">};  
	
		# add hidden fields/values # from $form_vars[4] 
		for (@hidden)
		{
			my ($name, $value) = split(/\-\-\-/, $_, 2) if $_; 
			$out .= qq{\n\t<input type="hidden" name="$name" value="$value"/>} if $_; 
		}
		# add select 
		$out .= qq{$select};  
	$out .= qq{\n\t<button type="submit" class="btn btn-default">Submit</button>\n</form>\n}; 
	
	return qq{<div class="body_form">$out</div>}; 
}

# end body_form 



sub defaults_begin
{
	my $self = shift; 
	
	my $out;
	
	$out .= sprintf header(),  
		start_html(),  
		head_title("$_[0]"),  
		head_meta(), 
		head_meta("$_[1]"), 
		head_js_css(),  
		head_js_css("$_[2]"),  
		end_head(),  
		begin_body(),  
		body_topnavbar()
	;
		
		return $out; 
}



sub defaults_end 
{
	my $self = shift; 
	
	my $out;
	
	$out .= sprintf body_js_css(),
		body_js_css("$_[0]"),
		end_body(), 
		end_html() 
	;
	
	return $out;
}



# HTML 
my %HTML;

%HTML = (
	-defaultjquery => qq{\n<!-- -defaultjquery-->

		<!-- jquery-->
		<script src="https://code.jquery.com/jquery-1.12.4.min.js"></script>

		<!--bootstrap-->
		<script  src="https://maxcdn.bootstrapcdn.com/bootstrap/3.3.0/js/bootstrap.min.js"></script>

		<!--blueimp gallery-->
		<script src="https://blueimp.github.io/Gallery/js/jquery.blueimp-gallery.min.js"></script>

		<!-- jquery ui -->
		<script src="https://code.jquery.com/ui/1.11.4/jquery-ui.min.js"></script>

		<!-- IE10 viewport hack for Surface/desktop Windows 8 bug -->
		<script  src="https://www.a1z.us/jquery/bootstrap/fixed-top/ie10-viewport-bug-workaround.js"></script>
		<script >
		
		// for tabs 
		\$( function() {
			var tabs = \$( "#tabs" ).tabs();
			
			tabs.find( ".ui-tabs-nav" ).sortable({
				axis: "x",
				stop: function() { tabs.tabs( "refresh" ); }
			});
		}); 
		  
		// dialog 
		\$(function() {
			\$( "#dialog" ).dialog({
			  autoOpen: false,
			  show: {
				effect: "blind",
				duration: 1000
			  },
			  hide: {
				effect: "explode",
				duration: 1000
			  }
			});
		 
			\$( "#opener" ).click(function() {
			  \$( "#dialog" ).dialog( "open" );
			});
		});
		  
		\$('#menu').menu(); 
		\$('#accordion').accordion(); 
		\$('#accordion1').accordion(); 
		\$('#accordion2').accordion(); 
		\$('#accordion3').accordion(); 
		\$('accordion617').accordion();
		\$('#tabs').tabs(); 

		
		</script>
	},
	
	-default_LastItem => qq{},
	
);


sub html_bootstrap_css   
{
	return qq{<!-- Bootstrap/jqueryUI -->
<link href="https://maxcdn.bootstrapcdn.com/bootstrap/3.3.0/css/bootstrap.min.css" rel="stylesheet" type="text/css">
<link href="https://www.a1z.us/jquery/bootstrap/fixed-top/navbar-fixed-top.css" rel="stylesheet">
};
  
}




sub html_jqueryui_css 
{
	# jquery ui theme jquery-ui.css #1.12.0
	return qq{<link href="https://code.jquery.com/ui/1.12.0/themes/smoothness/jquery-ui.css" rel="stylesheet">}; 
}




sub html_shim_respond 
{
	return qq{<!-- HTML5 shim and Respond.js for IE8 support of HTML5 elements and media queries -->
<!--[if lt IE 9]>
<script src="https://oss.maxcdn.com/html5shiv/3.7.2/html5shiv.min.js"></script>
<script src="https://oss.maxcdn.com/respond/1.4.2/respond.min.js"></script>
<![endif]-->
};

 view all matches for this distribution


A1z-Html

 view release on metacpan or  search on metacpan

lib/A1z/Html.pm  view on Meta::CPAN

sub NAME { my $self = shift; $NAME = "Web Utilities"; return $NAME; }

our $VERSION = '0.04';

sub new {
	my $class = shift;
	my $self  = bless { @_ }, $class;
	return $self;
}

sub welcome {
	return qq{Welcome to Web Utilities};
}

1;

__END__

 view all matches for this distribution


AAAA-Mail-SpamAssassin

 view release on metacpan or  search on metacpan

lib/AAAA/Mail/SpamAssassin.pm  view on Meta::CPAN

use warnings;
package AAAA::Mail::SpamAssassin;
# git description: v0.001-1-g4fcbc88

BEGIN {
  $AAAA::Mail::SpamAssassin::AUTHORITY = 'cpan:SCHWIGON';
}
{
  $AAAA::Mail::SpamAssassin::VERSION = '0.002';
}
# ABSTRACT: making Mail::SpamAssassin installable

1;

 view all matches for this distribution


ABI

 view release on metacpan or  search on metacpan

ABI.pm  view on Meta::CPAN


our $VERSION = '1.0';

=head1 SYNOPSIS

  my $abi = ABI->new(-file=>"mysequence.abi");
  my $seq = $abi->get_sequence(); # To get the sequence
  my @trace_a = $abi->get_trace("A"); # Get the raw traces for "A"
  my @trace_g = $abi->get_trace("G"); # Get the raw traces for "G"
  my @base_calls = $abi->get_base_calls(); # Get the base calls

=head1 DESCRIPTION

An ABI chromatogram file is in binary format. It contain several 
information only some of which is required for normal use. This

 view all matches for this distribution


ABNF-Grammar

 view release on metacpan or  search on metacpan

lib/ABNF/Generator.pm  view on Meta::CPAN

our @EXPORT_OK = qw($CONVERTERS $BASIC_RULES $RECURSION_LIMIT);

Readonly our $CHOICE_LIMIT => 128;

Readonly our $CONVERTERS => {
	"hex" => sub { hex($_[0]) },
	"bin" => sub { oct($_[0]) },
	"decimal" => sub { int($_[0]) },
};

=pod

=head1 ABNF::Generator->C<new>($grammar, $validator?)

 view all matches for this distribution


AC-DC

 view release on metacpan or  search on metacpan

lib/AC/ConfigFile/Simple.pm  view on Meta::CPAN

use strict;

my $MINSTAT = 15;

my %CONFIG = (
    include	=> \&include_file,
    debug	=> \&parse_debug,
    allow	=> \&parse_allow,
    _default	=> \&parse_keyvalue,
);


sub new {
    my $class = shift;
    my $file  = shift;

    my $me = bless {
	_laststat	=> $^T,
	_lastconf	=> $^T,
        _configfile	=> $file,
        _files		=> [ ],
	@_,
    }, $class;

    $me->_read();
    return $me;
}

sub check {
    my $me = shift;

    my $now = $^T;
    return if $now - $me->{_laststat} < $MINSTAT;
    $me->{_laststat} = $now;

    my $changed;
    for my $file ( @{$me->{_files}} ){
        my $mtime = (stat($file))[9];
        $changed = 1 if $mtime > $me->{_lastconf};
    }
    return unless $changed;

    verbose("config file changed. reloading");
    $me->{_lastconf} = $now;

    eval {
	$me->_read();
        verbose("installed new config file");
        if( my $f = $me->{onreload} ){
            $f->();
        }
    };
    if(my $e = $@){
        problem("error reading new config file: $e");
        return;
    }

    return 1;
}

sub _read {
    my $me = shift;

    delete $me->{_pending};

    $me->_readfile($me->{_configfile});

    $me->{config} = $me->{_pending};
    delete $me->{_pending};
}

sub _readfile {
    my $me   = shift;
    my $file = shift;

    my $fd;
    open($fd, $file) || die "cannot open file '$file': $!";
    $me->{fd} = $fd;

    push @{$me->{_files}}, $file;

    while( defined(my $l = $me->_nextline()) ){
        my($key, $rest) = split /\s+/, $l, 2;
        $me->handle_config( $key, $rest ) || die "invalid config '$key'\n";
    }

    close $fd;
}

sub handle_config {
    my $me   = shift;
    my $key  = shift;
    my $rest = shift;

    my $fnc = $CONFIG{$key} || $CONFIG{_default};
    return unless $fnc;
    $fnc->($me, $key, $rest);
    return 1;
}

sub _nextline {
    my $me = shift;

    my $line;
    while(1){
        my $fd = $me->{fd};

        my $l = <$fd>;
        return $line unless defined $l;
        chomp $l;

        $l =~ s/\#.*$//;
        $l =~ s/^\s*//;
        $l =~ s/\s+$//;
        next if $l =~ s/^\s*$/; #/;
        $line .= $l;

        if( $line =~ /\\$/ ){
            chop $line;
            next;
        }
        return $line;
    }
}

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

sub include_file {
    my $me   = shift;
    my $key  = shift;
    my $file = shift;

    $file =~ s/^"(.*)"$/$1/;

    if( $file !~ m|^/| ){
        # add path from main config file
        my($path) = $me->{_configfile} =~ m|(.*)/[^/]+$|;
        $file = "$path/$file" if $path;
    }

    my $fd = $me->{fd};
    $me->_readfile($file);
    $me->{fd} = $fd;
}

sub parse_keyvalue {
    my $me    = shift;
    my $key   = shift;
    my $value = shift;

    problem("parameter '$key' redefined") if $me->{_pending}{$key};
    $me->{_pending}{$key} = $value;
}

sub parse_keyarray {
    my $me    = shift;
    my $key   = shift;
    my $value = shift;

    push @{$me->{_pending}{$key}}, $value;
}

sub parse_allow {
    my $me    = shift;
    my $key   = shift;
    my $acl   = shift;

    my($host, $len) = split m|/|, $acl;
    $host ||= $acl;
    $len  ||= 32;

    push @{$me->{_pending}{acl}}, [ inet_aton($host), inet_lton($len) ];
}

sub parse_debug {
    my $me    = shift;
    my $key   = shift;
    my $value = shift;

    $me->{_pending}{debug}{$value} = 1;
}


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

sub config {
    my $me = shift;
    return $me->{config};
}

sub get {
    my $me = shift;
    my $k  = shift;

    return $me->{config}{$k};
}

sub check_acl {
    my $me = shift;
    my $ip = shift;	# ascii

    my $ipn = inet_aton($ip);
    for my $acl ( @{$me->{config}{acl}} ){
        my($net, $mask) = @$acl;
        return 1 if ($ipn & $mask) eq $net;
    }

    return 0;
}


1;

 view all matches for this distribution


AC-MrGamoo

 view release on metacpan or  search on metacpan

eg/filelist.pm  view on Meta::CPAN

use strict;

my $YDBFILE = "/data/files.ydb";

sub get_file_list {
    my $config = shift;

    # get files + metadata from yenta
    my $yenta = AC::Yenta::Direct->new( 'files', $YDBFILE );

    # the job config is asking for files that match:
    my $syst  = $config->{system};
    my $tmax  = $config->{end};		# time_t
    my $tmin  = $config->{start};	# time_t

    # the keys in  yenta are of the form: 20100126150139_[...]
    my $start = isotime($tmin);		# 1286819830       => 20101011T175710Z
    $start =~ s/^(\d+)T(\d+).*/$1$2/;	# 20101011T175710Z => 20101011175710


    my @files = grep {
        # does this file match the request?
        ($_->{subsystem}   eq $syst) &&
        ($_->{end_time}    >= $tmin) &&
        ($_->{start_time}  <= $tmax)
    } map {
        # get meta-data on this file. data is json encoded
        my $d = $yenta->get($_);
        $d = $d ? decode_json($d) : {};
        # convert space seperated locations to arrayref
        $d->{location} = [ (split /\s+/, $d->{location}) ];
        $d;
    } $yenta->getrange($start, undef);	# get all files from $start to now


    return \@files;
}


1;

 view all matches for this distribution


AC-Yenta

 view release on metacpan or  search on metacpan

eg/myself.pm  view on Meta::CPAN

use strict;

my $SERVERID;

sub init {
    my $class = shift;
    my $port  = shift;	# our tcp port
    my $id    = shift;  # from cmd line

    $SERVERID = $id;
    unless( $SERVERID ){
        (my $h = hostname()) =~ s/\.example.com//;	# remove domain
        $SERVERID = "yenta/$h";
    }
    verbose("system persistent-id: $SERVERID");
}

sub my_server_id {
    return $SERVERID;
}

1;

 view all matches for this distribution


ACH-Generator

 view release on metacpan or  search on metacpan

lib/ACH/Generator.pm  view on Meta::CPAN

package ACH::Generator;

$VERSION = '0.01';

use strict;
use warnings;

use ACH;

sub _croak { require Carp; Carp::croak(@_) }

=head1 NAME

ACH::Generator - Generates an ACH formatted file from an ACH perl object
	
=head1 VERSION

Version: 0.01
May 2006

=head1 DESCRIPTION

ACH::Generator is a simple, generic subclass of ACH used to generate ACH files.
It's intentional use is for testing purposes ONLY.  ACH-Generator will allow a 
developer to create an ACH formatted file.

=head1 USING ACH-Generator

	use ACH::Generator;

	my $newACH = new ACH;
	my $newACHfile = 'newACHFile.ACH';	# The name of the ACH file to be generated
	
	...
	
	$newACH->generate($newACHfile);

=head1 METHODS

=head2 generate

Generates an ACH file from the data in the ACH object

=cut

# Generate the ACH file 
sub ACH::generate {
  # Get the file name
  my $self = shift; 
  my $file = shift or _croak "Need an ACH file";
  
  # File data
  my $data = "";
  
  # Iterate through the ACH Data
  foreach my $item (@{$self->{_achData}}) { # Array of ACH file Sections
    my @achSections = map { defined $_ ? $_ : '' } @{$item};
    my $sectionValue = 0;
    
    for (my $y=0; $y < @achSections; $y++) { # Array of ACH file Section data
      my %hash = map { defined $_ ? $_ : '' } %{$achSections[$y]};
      
      # Use the appropriate file Format size for the appropriate ACH file section
      foreach my $hashItem (keys (%hash)) { # Hash containing the ACH field name and value
        chomp $hash{$hashItem};
        my $dataValue = "";

		# Get the section header in the first field, else get the data        
        if ($y == 0) { $dataValue = $sectionValue = $hash{$hashItem}; }
        else { 
          # Get the field length and data
		  my $field = ${$self->{_achFormats}{$sectionValue}}[$y];
          my ($field_length);  while ( my ($key, $value) = each(%$field) ) { $field_length = $value; }
          $dataValue = substr($hash{$hashItem}, 0, $field_length); 
        }
        
        # Store the data in the file data variable
        $data .= $dataValue;
      }
    }
  }
  
  # Open the file
  if ( open(OUTPUT, ">$file") ) {}
  else { print "Error:  Couldn't open file $file\n"; die; }

  # Print data out to ACH file
  print OUTPUT "$data";

  # Close the ACH file
  close (OUTPUT);
}


=head2 CAVEATS

This package is created for testing purposes only.  It shouldn't be used 
for production programs or scripts.  There are other commercial products
out there that may be a more efficient solution for accomplishing your
goals.

All records in an ACH file must be formatted in the following sequence
of records.  IF the file is not formatted in this exact sequence, it
may be rejected.

ACH File Layout:
1 - File Header Record
5 - First Company/Batch Header Record
6 - First Entry Detail Record
7 - First Entry Detail Addenda Record (optional)
	|
Multiples of Entry Detail Records
	|
6 - Last Entry Detail Record
7 - Last Entry Detail Addenda Record (optional)
8 - First Company/Batch Control Record
	|
Multiples of Company/Batches
	|
5 - Last Company/Batch Header Record
6 - First Entry Detail Record
7 - First Entry Detail Addenda Record (optional)
	|
Multiples of Entry Detail Records
	|
6 - Last Entry Detail Record
7 - Last Entry Detail Addenda Record (optional)
8 - Last Company/Batch Control Record
9 - File Control Record
9999...9999 (optional)

=head1 AUTHOR

Author: Christopher Kois
Date: May, 2006
Contact: cpkois@cpan.org

=head1 COPYRIGHTS

The ACH-Generator module is Copyright (c) May, 2006 by Christopher Kois. 
http://www.christopherkois.com All rights reserved.  You may distribute this 
module under the terms of GNU General Public License (GPL). 

=head1 SUPPORT/WARRANTY

ACH-Generator is free Open Source software. IT COMES WITHOUT WARRANTY OR SUPPORT OF ANY KIND.

=head1 KNOWN BUGS

This is version 0.01 of ACH::Generator.  There are currently no known bugs.

=head1 SEE ALSO

L<ACH>. L<ACH::Parser>

=cut

1;

 view all matches for this distribution


ACH-Parser

 view release on metacpan or  search on metacpan

lib/ACH/Parser.pm  view on Meta::CPAN

package ACH::Parser;

$VERSION = '0.01';

use strict;
use warnings;

use ACH;

sub _croak { require Carp; Carp::croak(@_) }

=head1 NAME

ACH::Parser - Parse an ACH formatted file to ACH perl object
	
=head1 VERSION

Version: 0.01
May 2006

=head1 DESCRIPTION

ACH::Parser is a simple, generic ACH file to ACH object parser.
It's intentional use is for testing purposes ONLY.  ACH-Parser will
allow a developer to look at the particular fields in an ACH formatted
file.

=head1 USING ACH-Parser

	use ACH::Parser;

	my $file = 'RETODC0104A.ACH';
	my $ach = new ACH;
	$ach->parse($file);

=head1 METHODS

=head2 parse

Parses the ACH data into the ACH object

=cut

# Parse the ACH file formatted text into an ACH object
sub ACH::parse {
  # Get the file name
  my $self = shift; 
  my $file = shift or _croak "Need an ACH file";
  
  # Open the file
  if ( open(INPUT, "$file") ) {}
  else { print "Error:  Couldn't open file $file\n"; die; }

  # Get the file contents
  my @data = <INPUT>;
  my $dataline = $data[0];
  my $pos = 0;
  
  # Loop Through all entries
  while ($pos < length($dataline)) {
    # Get the correct ACH format array and store all parsed data in a hash
    my $desc = substr($dataline, $pos, 1);
    my @dataArray = [];

    # Make sure file descriptor is valid
    if ($desc != 1 and $desc != 5 and $desc != 6 and $desc != 7 and $desc != 8 and $desc != 9) {
      die "File Error:  Code: $desc\n";
    }
    
    # Iterate through the appropriate ACH file format array and parse the data
    for (my $x=0; $x < @{$self->{_achFormats}{$desc}}; $x++) {
	  my $field = ${$self->{_achFormats}{$desc}}[$x];
            
	  # Get the field name and length
	  my ($field_name, $field_length);
	  while ( my ($key, $value) = each(%$field) ) { $field_name = $key;  $field_length = $value; }

      # Get the ACH Data from the file
      my $part = substr($dataline, $pos, $field_length);  chomp $part;
      my %hash = ($field_name => $part);
      $dataArray[$x] = \%hash;
      $pos += $field_length;    
    }
    
    # Save data to list
    @{$self->{_achData}}[scalar @{$self->{_achData}}] = \@dataArray; 
  }
  
  # Close the Input file
  close (INPUT);
}


=head2 CAVEATS

This package is created for testing purposes only.  It shouldn't be used 
for production programs or scripts.  There are other commercial products
out there that may be a more efficient solution for accomplishing your
goals.

All records in an ACH file must be formatted in the following sequence
of records.  IF the file is not formatted in this exact sequence, it
may be rejected.

ACH File Layout:
1 - File Header Record
5 - First Company/Batch Header Record
6 - First Entry Detail Record
7 - First Entry Detail Addenda Record (optional)
	|
Multiples of Entry Detail Records
	|
6 - Last Entry Detail Record
7 - Last Entry Detail Addenda Record (optional)
8 - First Company/Batch Control Record
	|
Multiples of Company/Batches
	|
5 - Last Company/Batch Header Record
6 - First Entry Detail Record
7 - First Entry Detail Addenda Record (optional)
	|
Multiples of Entry Detail Records
	|
6 - Last Entry Detail Record
7 - Last Entry Detail Addenda Record (optional)
8 - Last Company/Batch Control Record
9 - File Control Record
9999...9999 (optional)

=head1 AUTHOR

Author: Christopher Kois
Date: May, 2006
Contact: cpkois@cpan.org

=head1 COPYRIGHTS

The ACH-Parser module is Copyright (c) May, 2006 by Christopher Kois. 
http://www.christopherkois.com All rights reserved.  You may distribute this 
module under the terms of GNU General Public License (GPL). 

=head1 SUPPORT/WARRANTY

ACH-Parser is free Open Source software. IT COMES WITHOUT WARRANTY OR SUPPORT OF ANY KIND.

=head1 KNOWN BUGS

This is version 0.01 of ACH::Parser.  There are currently no known bugs.

=head1 SEE ALSO

L<ACH>. L<ACH::Generator>

=cut

1;

 view all matches for this distribution


ACH

 view release on metacpan or  search on metacpan

lib/ACH.pm  view on Meta::CPAN

package ACH;

$VERSION   = '0.01';		# Version number

use strict;
use warnings;

=head1 NAME

ACH - ACH perl object
	
=head1 VERSION

Version: 0.01
May 2006

=head1 DESCRIPTION

ACH is a simple, generic perl object that contains the data necesary to
create an ACH file.  It's intentional use is for testing purposes ONLY.  
ACH will allow a developer to manipulate specific data fields in an ACH 
formatted object.

=head1 USING ACH

	my $ACH = new ACH;

=cut

### Variables and functions

## Arrays that store sizes of the various records in the ACH file ##
# File Header Format fields and field sizes
my @fileFormat = ({'File Header Record' => 1}, {'Priority Code' => 2}, 
{'Immediate Destination' => 10}, {'Immediate Origin' => 10}, {'File Creation Date' => 6},
{'Creation Time' => 4}, {'File ID Modifier' => 1}, {'Record size' => 3}, {'Blocking Factor' => 2},
{'Format Code' => 1}, {'Destination' => 23}, {'Origin' => 23}, {'Reference Code' => 8});

# Batch Record fields and field sizes
my @batchFormat = ({'Batch Header Record' => 1}, {'Service Class Code' => 3}, 
{'Company Name' => 16}, {'Company Discretionary Data' => 20}, {'Company Identification' => 10}, 
{'Standard Entry Classes' => 3}, {'Company Entry Description' => 10}, 
{'Company Descriptive Date' => 6}, {'Effective Entry Date' => 6}, {'Settlement Date' => 3},
{'Originator Status Code' => 1}, {'Originating DFI Identification' => 8}, {'Batch #' => 7});

# Detail Record fields and field sizes
my @detailFormat = ({'Entry Detail Record' => 1}, {'Transaction Code' => 2}, 
{'Individual Bank ID' => 8}, {'Check Digit' => 1}, {'Bank Acct. Number' => 17}, {'Amount' => 10},
{'Individual ID Number' => 15}, {'Individual Name' => 22}, {'Bank Discretionary Data' => 2},
{'Addenda Record Indicator' => 1}, {'Trace Number' => 15});

# Addenda Format fields and field sizes
my @addendaFormat = ({'Addenda Record' => 1}, {'Addenda Type Code' => 2}, 
{'Payment Related Information' => 80}, {'Special Addenda Sequence Number' => 4},
{'Entry Detail Sequence Number' => 7});

# Batch Control Format fields and field sizes
my @controlFormat = ({'Batch Control Record' => 1}, {'Service Class Codes' => 3},
{'Entry/Addenda Count' => 6}, {'Entry Hash' => 10}, {'Total Debit Entry Dollar Amount' => 12}, 
{'Total Credit Entry Dollar Amount' => 12}, {'Company Identification' => 10}, {'Blank' => 19},
{'Blank' => 6}, {'Originating Financial Institution' => 8}, {'Batch Number' => 7});

# File Control fields and field sizes
my @fileControl = ({'File Control Record' => 1}, {'Batch Count' => 6}, {'Block Count' => 6}, 
{'Entry/Addenda Count' => 8}, {'Entry Hash' => 10}, {'Total Debit Entry Dollar Amount' => 12}, 
{'Total Credit Entry Dollar Amount' => 12}, {'Reserved/Blank' => 39});

# All of the ACH File Formats
my %achFormats = (1 => \@fileFormat, 5 => \@batchFormat, 6 => \@detailFormat, 
7 => \@addendaFormat, 8 => \@controlFormat, 9 => \@fileControl);
##

# ACH data
my @achData;

=head1 METHODS

=head2 new

Creates a new ACH object

=cut

# Create a new ACH object
sub new  { 
    my $class = shift;
    my $self  = {};         # allocate new hash for object
    
    bless {
      _achData         => [],
      _achFormats      => \%achFormats,
    }, $class;
}

=head2 printAllData

Prints all the ACH data

=cut

# Print all data from the ACH object
sub printAllData {
  my $self = shift;
  foreach my $item (@{$self->{_achData}}) { # Array of ACH file Sections
    my @achSections = map { defined $_ ? $_ : '' } @{$item};
    foreach my $section (@achSections) { # Array of ACH file Section data
      my %hash = map { defined $_ ? $_ : '' } %{$section};
      foreach my $hashItem (keys (%hash)) { # Hash containing the ACH field name and value
        print "$hashItem: $hash{$hashItem}\n";
      }
    }
  }
}

=head2 getData

Returns the ACH data

=cut

# Get data
sub getData {
  my $self = shift;
  return \@{$self->{_achData}};
}


=head2 CAVEATS

This package is created for testing purposes only.  It shouldn't be used 
for production programs or scripts.  There are other commercial products
out there that may be a more efficient solution for accomplishing your
goals.

All records in an ACH file must be formatted in the following sequence
of records.  IF the file is not formatted in this exact sequence, it
may be rejected.

ACH File Layout:
1 - File Header Record
5 - First Company/Batch Header Record
6 - First Entry Detail Record
7 - First Entry Detail Addenda Record (optional)
	|
Multiples of Entry Detail Records
	|
6 - Last Entry Detail Record
7 - Last Entry Detail Addenda Record (optional)
8 - First Company/Batch Control Record
	|
Multiples of Company/Batches
	|
5 - Last Company/Batch Header Record
6 - First Entry Detail Record
7 - First Entry Detail Addenda Record (optional)
	|
Multiples of Entry Detail Records
	|
6 - Last Entry Detail Record
7 - Last Entry Detail Addenda Record (optional)
8 - Last Company/Batch Control Record
9 - File Control Record
9999...9999 (optional)

=head1 AUTHOR

Author: Christopher Kois
Date: May, 2006
Contact: cpkois@cpan.org

=head1 COPYRIGHTS

The ACH module is Copyright (c) May, 2006 by Christopher Kois. 
http://www.christopherkois.com All rights reserved.  You may distribute 
this module under the terms of GNU General Public License (GPL). 

=head1 SUPPORT/WARRANTY

ACH is free Open Source software. IT COMES WITHOUT WARRANTY OR SUPPORT OF ANY KIND.

=head1 KNOWN BUGS

This is version 0.01 of ACH.  There are currently no known bugs.

=head1 SEE ALSO

L<ACH::Generator>. L<ACH::Parser>

=cut

1;

 view all matches for this distribution


ACL-Lite

 view release on metacpan or  search on metacpan

lib/ACL/Lite.pm  view on Meta::CPAN


our $VERSION = '0.0004';

=head1 SYNOPSIS

    use ACL::Lite;

    $acl = ACL::Lite->new(permissions => 'foo,bar');

    $acl->check('foo');

    if ($ret = $acl->check([qw/baz bar/])) {
        print "Check successful with permission $ret\n";
    }

    unless ($acl->check('baz')) {
        print "Permission denied\n";
    }

    $acl = ACL::Lite->new(uid => 666);

    $acl->check('authenticated');

=head1 DESCRIPTION

C<ACL::Lite> is a simple permission checker without any prerequisites.

 view all matches for this distribution


ACL-Regex

 view release on metacpan or  search on metacpan

examples/postifx-policy-server.pl  view on Meta::CPAN

our %redirectmap;

# Param1: Client socket
# Param2: hash_ref
sub parse_postfix_input( $$ ) {
	my ($socket,$hashref) = @_;

	local $/ = "\r\n";
	while( my $line = <$socket> ){
		chomp( $line );
		$line =~ s/\r//g;
		$line =~ s/\n//g;

		return if $line =~ /^(\r|\n)*$/;
		#print "DEBUG: $line" if $debug;
		if( $line =~ /^(\w+?)=(.+)$/ ){
			$hashref->{$1} = $2;
		}
	}
}

sub convert_hashref_to_acl($){
	my( $hash_ref ) = @_;
	
	my @a;

	for( sort( keys %$hash_ref ) ) {
		my $str = "$_=\[$hash_ref->{$_}\]";
		push( @a, $str );
	}

	return( join( " ", @a ) );
}

sub process_client($){
	my ($socket) = @_;

	# Create some stuff
	my $accept_acl = ACL->new->generate_required( 'required.txt' )->parse_acl_from_file( { Filename => "acl.permit.txt" } );
	my $reject_acl = ACL->new->generate_required( 'required.txt' )->parse_acl_from_file( { Filename => "acl.reject.txt" } );

	ACCEPT: while( my $client = $socket->accept() ){
		my $hash_ref = {};
		parse_postfix_input( $client, $hash_ref );

		my $action = convert_hashref_to_acl( $hash_ref );

		print "Action: " . Dumper($action) . "\n";

		my ($rc,$regex,$comment) = $reject_acl->match( $action );
		print Dumper( $rc ) . Dumper( $regex ) . Dumper( $comment ) . "\n";

		if( $rc ){
			print $client "action=reject $comment\n\n";
			next ACCEPT;
			# Match
		}

		($rc,$regex,$comment) = $accept_acl->match( $action );
		print Dumper( $rc ) . Dumper( $regex ) . Dumper( $comment ) . "\n";
		if( $rc ){
			print $client "action=ok $comment\n\n";
			next ACCEPT;
			# Match
		}

		# Handle any redirects
		print $client "action=dunno\n\n";
	}
}

sub handle_sig_int
{
	unlink( $pidfile );
	exit(0);
}

#openlog('missed-spam-policy', '', 'mail');
#syslog('info', 'launching in daemon mode') if $ARGV[0] eq 'quiet-quick-start';
#Proc::Daemon::Init if $ARGV[0] eq 'quiet-quick-start';

 view all matches for this distribution


ACME-Dzil-Test-daemon

 view release on metacpan or  search on metacpan

lib/ACME/Dzil/Test/daemon.pm  view on Meta::CPAN


This software is Copyright (c) 2021 by Paul G Webster.

This is free software, licensed under:

  The (three-clause) BSD License

 view all matches for this distribution


ACME-Dzil-Test-daemon2

 view release on metacpan or  search on metacpan

lib/ACME/Dzil/Test/daemon2.pm  view on Meta::CPAN


This software is Copyright (c) 2021 by Paul G Webster.

This is free software, licensed under:

  The (three-clause) BSD License

 view all matches for this distribution


ACME-Error-31337

 view release on metacpan or  search on metacpan

31337.pm  view on Meta::CPAN

$VERSION = '0.01';

use Lingua::31337 qw[text231337];

*die_handler = *warn_handler = sub {
  return text231337 @_;
};

1;
__END__

 view all matches for this distribution


ACME-Error-HTML

 view release on metacpan or  search on metacpan

HTML.pm  view on Meta::CPAN

$VERSION = '0.01';

use HTML::FromText;

*die_handler = *warn_handler = sub {
  return text2html "@_",
                   paras        => 1,
                   bold         => 1,
                   metachars    => 0,
                   urls         => 1,
                   email        => 1,
                   underline    => 1,
                   blockparas   => 1,
                   numbers      => 1,
                   bullets      => 1;
};

1;
__END__

 view all matches for this distribution


ACME-MBHall

 view release on metacpan or  search on metacpan

lib/ACME/MBHall.pm  view on Meta::CPAN


Quick summary of what the module does.

Perhaps a little code snippet.

    use ACME::MBHall;

    my $foo = ACME::MBHall->new();
    ...

=head1 EXPORT

A list of functions that can be exported.  You can delete this section
if you don't export anything, such as for a purely object-oriented module.

 view all matches for this distribution


ACME-MSDN-SPUtility

 view release on metacpan or  search on metacpan

lib/ACME/MSDN/SPUtility.pm  view on Meta::CPAN

Checks whether the Taiwan calendar is hidden based on the specified Web site and locale ID.
Checks if the China Gov really Lost Their Brain based on the specified Web site and locale ID.
Checks if Bill-GAY$ and his 'Stuffz' lost thier Balls at Halloween based on the specified Web site and locale ID.


	use ACME::MSDN::SPUtility;

	my $fool = ACME::MSDN::SPUtility->new( $SPWeb, int $localeId);
	say 'Hello, Taiwan!' if not $fool->HideTaiwan;
	STDERR->say("I can't speak well if I don't have a brain!") if $fool->HideChina;
	say STDERR 'Plz find my balls for me and give it back to me. I lost all of them!' if $fool->HideMicroSoft;

=head1 FUNCTIONS

=head2 new

Get a SPUtility object.

=cut

sub new {
	my $this = shift;
	my $class = ref($this) || $this;
	my $self = {};
	bless $self, $class;
	#$self->initialize();
	return $self;
}

=head2 HideTaiwan

Checks whether the Taiwan calendar is hidden based on the specified Web site and locale ID.

=cut

sub HideTaiwan {
	my $self = shift;
	my ($spWeb, $localeId) = @_;
	
	print "Taiwan is definitely a Contry already, and should never hide. Is china scared by this?";
	return undef;
};

=head2 HideChina

Checks if the China Gov really Lost Their Brain based on the specified Web site and locale ID.

=cut

sub HideChina {
	my $self = shift;
	my ($spWeb, $localeId) = @_;
	
	print "fsck the dumb China gov";
	return 1;
}

=head2 HideMicroSoft

Checks if Bill-GAY$ and his 'Stuffz' lost thier Balls at Halloween based on the specified Web site and locale ID.

=cut

sub HideMicroSoft {
	my $self = shift;
	my ($spWeb, $localeId) = @_;
	
	print 'Bill-Gay$ and Micro$oft Stuff$ lost their Ballz, did you see them?';
	return 1;
}

=head1 AUTHOR

BlueT - Matthew Lien - 練喆明, C<< <BlueT at BlueT.org> >>

 view all matches for this distribution


ACME-QuoteDB

 view release on metacpan or  search on metacpan

lib/ACME/QuoteDB.pm  view on Meta::CPAN


binmode STDOUT, ':encoding(utf8)';
binmode STDERR, ':encoding(utf8)';

sub new {
    my $class = shift;
    my $self = bless {}, $class;
    return $self;
}

# provide 1 non OO method for one liners
sub quote {
    my ($arg_ref) = @_;
    return get_quote(q{}, $arg_ref);
}

# list of quote attributions (names) (makes searching easier)
sub list_attr_names {
   return _get_field_all_from('name', Attr->retrieve_all);
}

# list of quote categories
sub list_categories {
   return _get_field_all_from('catg', Catg->retrieve_all);
}

## list of quote sources
sub list_attr_sources {
   return _get_field_all_from('source', Quote->retrieve_all);
}

sub _get_field_all_from {
   my ($field, @all_stored) = @_;

    my $arr_ref = [];
    RECORDS:
    foreach my $f_obj (@all_stored){
        my $s = $f_obj->$field;
        # if doesn't exist and not a dup
        if (! $f_obj->$field || scalar grep {/$s/sm} @{$arr_ref}){
            next RECORDS;
        }
        push @{ $arr_ref }, $f_obj->$field;
    }
    return join "\n", sort @{$arr_ref};
}

sub _get_attribution_ids_from_name {
    my ($attr_name) = @_;

    my $c_ids = [];
    # a bug: what if string starts with what we specify
    #i.e. => %Griffin% doesn' match 'Griffin' (no quotes)
    RESULTS:
    foreach my $c_obj (Attr->search_like(name => "%$attr_name%")){
       next RESULTS unless $c_obj->attr_id;
       push @{ $c_ids }, $c_obj->attr_id;
    }

    if (not scalar @{$c_ids}) {
        croak 'attribution not found';
    }

    return $c_ids;

}

sub _get_quote_id_from_quote {
    my ($quote) = @_;

    my $q_ids = [];
    # a bug: what if string starts with what we specify
    #i.e. => %Griffin% doesn' match 'Griffin' (no quotes)
    RESULTS:
    foreach my $c_obj (Quote->search(quote => $quote)){
       next RESULTS unless $c_obj->quot_id;
       push @{ $q_ids }, $c_obj->quot_id;
    }

    if (not scalar @{$q_ids}) {
        croak 'quote not found';
    }

    return $q_ids;

}

# can handle scalar or array ref
sub _rm_beg_end_space {
    my ($v) = @_;
    return unless $v;
    if (ref $v eq 'ARRAY'){
      my $arr_ref = ();
      foreach my $vl (@{$v}){
          push @{$arr_ref}, _rm_beg_end_space($vl);
      }
      return $arr_ref;
    }
    else {
      $v =~ s/\A\s+//xmsg;
      $v =~ s/\s+\z//xmsg;
      return $v;
    }
  return;
}

sub _get_one_rand_quote_from_all {
    #my $quotes_ref = [];
    #foreach my $q_obj (Quote->retrieve_all){
    #    next unless $q_obj->quote;
    #    my $record = Attr->retrieve($q_obj->attr_id);
    #    my $attr_name = $record->name || q{};
    #    push @{ $quotes_ref }, $q_obj->quote . "\n-- $attr_name";
    #}
    my $quotes_ref = _get_quote_ref_from_all(Quote->retrieve_all);
    return $quotes_ref->[rand scalar @{$quotes_ref}];
}

sub _get_rating_params {
    my ($rating) = @_;
    return unless $rating;

    my ($lower, $upper) = (q{}, q{});
    ($lower, $upper) = split /-/sm, $rating;

    if ($upper && !$lower) { croak 'negative range not permitted'};

    return (_rm_beg_end_space($lower), _rm_beg_end_space($upper));
}

sub _get_if_rating {
    my ($lower, $upper) = @_;

    if ($lower and $upper) { # a range, find within
        $lower =  qq/ AND rating >= '$lower' /;
        $upper =  qq/ AND rating <= '$upper' /;
    }
    elsif ($lower and not $upper) { # not a range, find exact rating
        $lower =  qq/ AND rating = '$lower' /
        #$upper = q{};
    }
    elsif ($upper and not $lower) {
        $upper =  qq/ AND rating = '$upper' /
        #$lower = q{};
    }

    return ($lower, $upper);
}

sub _get_ids_if_catgs_exist {
    my ($catgs) = @_;

    my $catg_ids = ();
    # get category id
    RECS:
    foreach my $c_obj (Catg->retrieve_all){
        next RECS if not $c_obj->catg;

        if (ref $catgs eq 'ARRAY'){
          foreach my $c (@{$catgs}){
            if ($c_obj->catg eq $c){
              # use cat_id if already exists
              push @{$catg_ids}, $c_obj->catg_id;
            }
          }
        }
        else {
          if ($c_obj->catg eq $catgs){
            # use cat_id if already exists
            push @{$catg_ids}, $c_obj->catg_id;
          }
        }
    }
    return $catg_ids;
}

sub _get_quote_id_from_catg_id {
    my ($catg_ids) = @_;

    my $quote_ids = ();
    RECS:
    foreach my $qc_obj (QuoteCatg->retrieve_all){
        next RECS if not $qc_obj->quot_id;

        if (ref $catg_ids eq 'ARRAY'){
          foreach my $c (@{$catg_ids}){
            if ($qc_obj->catg_id eq $c){
              # use cat_id if already exists
              push @{$quote_ids}, $qc_obj->quot_id;
            }
          }
        }
        else {
          if ($qc_obj->catg_id eq $catg_ids){
            # use cat_id if already exists
            push @{$quote_ids}, $qc_obj->quot_id;
          }
        }
    }
    return $quote_ids;
}

sub _untaint_data {
   my ($arr_ref) = @_;
   my $ut_ref = ();
   foreach my $q (@{$arr_ref}){
      if ($q =~ m{\A([0-9]+)\z}sm){
          push @{$ut_ref}, $1;
      }
   }
   return $ut_ref;
}

# TODO fixme: arg list too long
sub _get_rand_quote_for_attribution {
    my ($attr_name, $lower, $upper, $limit, $contain, $source, $catgs) = @_;

    $attr_name ||= q{};
    $lower     ||= q{};
    $upper     ||= q{};
    $limit     ||= q{};
    $contain   ||= q{};
    $source    ||= q{};
    $catgs     ||= q{};

    my $ids = _get_attribution_ids_from_name($attr_name);
    my $phs = _make_correct_num_of_sql_placeholders($ids);

    if ($attr_name) {
        $attr_name =  qq/ attr_id IN ($phs) /;
    }
    else {
        # why would we want this method without a attribution arg?
        # still, let's handle gracefully
        $attr_name =  q/ attr_id IS NOT NULL /;
        $ids = [];
    }

    if ($source) {
        $source =~ s{'}{''}gsm; # sql escape single quote
        $source =  qq/ AND source = '$source' /;
    }
    my $qids =  q{};
    if ($catgs) {
        $catgs  = _get_ids_if_catgs_exist($catgs);
        my $qid_ref = _get_quote_id_from_catg_id($catgs);
        $qids =  join ',', @{_untaint_data($qid_ref)};
        $qids  =  qq/ AND quot_id IN ($qids) /;
    }

    ($lower, $upper) = _get_if_rating($lower, $upper);

    if ($contain) { $contain =  qq/ AND quote LIKE '%$contain%' / }
    if ($limit) { $limit =  qq/ LIMIT '$limit' / };

    my @q = Quote->retrieve_from_sql(
              qq{ $attr_name $lower $upper $source $qids $contain $limit },
              @{$ids}
            );

    # XXX code duplication but smaller footprint
    # choosing not less code duplication, we'll see,...
    #my $quotes_ref = [];
    #foreach my $q_obj ( @q ){
    #    next unless $q_obj->quote;
    #    my $record = Attr->retrieve($q_obj->attr_id);
    #    my $attr_name = $record->name || q{};
    #    push @{ $quotes_ref }, $q_obj->quote . "\n-- $attr_name";
    #}
    #return _get_quote_ref_from_all(\@q);
    # XXX array_ref does not work here!
    return _get_quote_ref_from_all(@q);

    #return $quotes_ref;
}

sub _get_quote_ref_from_all {
    my (@results) = @_;
    #my ($results) = @_;

    my $quotes_ref = [];
    #foreach my $q_obj ( @{$results} ){
    foreach my $q_obj ( @results ){
        next unless $q_obj->quote;
        my $rec = Attr->retrieve($q_obj->attr_id);
        my $attr_name = $rec->name || q{};
        push @{ $quotes_ref }, $q_obj->quote . "\n-- $attr_name";
    }

    return $quotes_ref;
}

sub _args_are_valid {
    my ( $arg_ref, $accepted ) = @_;

    my $arg_ok = 0;
    foreach my $arg ( %{$arg_ref} ) {
        if ( scalar grep { $arg =~ $_ } @{$accepted} ) {
            $arg_ok = 1;
        }
    }

   if (!$arg_ok) {croak 'unsupported argument option passed'}
}

sub add_quote {
    my ( $self, $arg_ref ) = @_;

    _args_are_valid($arg_ref, [qw/Quote AttrName Source Rating Category/]);

    my $load_db = ACME::QuoteDB::LoadDB->new({
                                #verbose => 1,
                  });

    $load_db->set_record(quote  => $arg_ref->{Quote});
    $load_db->set_record(name   => $arg_ref->{AttrName});
    $load_db->set_record(source => $arg_ref->{Source});
    $load_db->set_record(catg   => $arg_ref->{Category});
    $load_db->set_record(rating => $arg_ref->{Rating});

    if ($load_db->get_record('quote') and $load_db->get_record('name')) {
        return $load_db->write_record;
    }
    else {
        croak 'quote and attribution name are mandatory parameters';
    }

    return;
}

# XXX lame, can only get an id from exact quote
sub get_quote_id {
    my ( $self, $arg_ref ) = @_;

    if (not $arg_ref) {croak 'Quote required'}

    _args_are_valid($arg_ref, [qw/Quote/]);

    my $ids = _get_quote_id_from_quote($arg_ref->{'Quote'});

    return join "\n", sort @{$ids};
}

sub update_quote {
    my ( $self, $arg_ref ) = @_;

    if (not $arg_ref) {croak 'QuoteId and Quote required'}

    _args_are_valid($arg_ref, [qw/Quote QuoteId Source 
                                  Category Rating AttrName/]);

    my $q = Quote->retrieve($arg_ref->{'QuoteId'});

    my $atr = Attr->retrieve($q->attr_id);

    # XXX need to support multi categories
    #my $ctg = Catg->retrieve($q->catg_id);
    my $qc = QuoteCatg->retrieve($q->quot_id);

    my $ctg = Catg->retrieve($qc->catg_id);

    $q->quote($arg_ref->{'Quote'});

    if ($arg_ref->{'Source'}){$q->source($arg_ref->{'Source'})}

    if ($arg_ref->{'Rating'}){$q->rating($arg_ref->{'Rating'})};

    if ($arg_ref->{'AttrName'}){$atr->name($arg_ref->{'AttrName'})};

    # XXX need to support multi categories
    if ($arg_ref->{'Category'}){
       $ctg->catg($arg_ref->{'Category'})
    }

    return ($q->update && $atr->update && $ctg->update);
}

sub delete_quote {
    my ( $self, $arg_ref ) = @_;

    if (not $arg_ref) {croak 'QuoteId required'}

    _args_are_valid($arg_ref, [qw/QuoteId/]);

    my $q = Quote->retrieve($arg_ref->{'QuoteId'});

    #$q->quote($arg_ref->{'QuoteId'});

    return $q->delete;

}

sub get_quote {
    my ( $self, $arg_ref ) = @_;

    # default use case, return random quote from all
    if (not $arg_ref) {
        return _get_one_rand_quote_from_all;
    }

    _args_are_valid($arg_ref, [qw/Rating AttrName Source Category/]);

    my ($lower, $upper) = (q{}, q{});
    if ($arg_ref->{'Rating'}) {
        ($lower, $upper) = _get_rating_params($arg_ref->{'Rating'});
    }

    my $attr_name = q{};
    if ( $arg_ref->{'AttrName'} ) {
        $attr_name = _rm_beg_end_space($arg_ref->{'AttrName'});
    }

    my $source = q{};
    if ( $arg_ref->{'Source'} ) {
        $source = _rm_beg_end_space($arg_ref->{'Source'});
    }

    my $catg; # will become scalar or array ref
    if ( $arg_ref->{'Category'} ) {
       $catg = _rm_beg_end_space($arg_ref->{'Category'});
    }

    # use case for attribution, return random quote
    my $quotes_ref =
          _get_rand_quote_for_attribution($attr_name, $lower,
                     $upper, q{}, q{}, $source, $catg);

    # one random from specified pool
    return $quotes_ref->[rand scalar @{$quotes_ref}];

}

# XXX isn't there a method in DBI for this, bind something,...
# TODO follow up 
sub _make_correct_num_of_sql_placeholders {
    my ($ids) = @_;
    # XXX a hack to make a list of '?' placeholders
    my @qms = ();
    for (1..scalar @{$ids}) {
       push @qms, '?';
    }
    return join ',', @qms;
}

sub get_quotes {
    my ( $self, $arg_ref ) = @_;

    # default use case, return random quote from all
    if (not $arg_ref) {
        return _get_one_rand_quote_from_all;
    }

    _args_are_valid($arg_ref, [qw/Rating AttrName Limit Category Source/]);

    my ($lower, $upper) = (q{}, q{});
    if ($arg_ref->{'Rating'}) {
        ($lower, $upper) = _get_rating_params($arg_ref->{'Rating'});
    }

    my $limit = q{};
    if ($arg_ref->{'Limit'}) {
        # specify 'n' amount of quotes to limit by
        $limit = _rm_beg_end_space($arg_ref->{'Limit'});
    }

    my $attribution = q{};
    if ( $arg_ref->{'AttrName'} ) {
        $attribution = _rm_beg_end_space($arg_ref->{'AttrName'});
    }

    my $source = q{};
    if ( $arg_ref->{'Source'} ) {
        $source = _rm_beg_end_space($arg_ref->{'Source'});
    }

    my $catg = q{};
    if ( $arg_ref->{'Category'} ) {
        $catg = _rm_beg_end_space($arg_ref->{'Category'});
    }
    # use case for attribution, return random quote
    return _get_rand_quote_for_attribution($attribution, $lower,
                     $upper, $limit, q{}, $source, $catg);

}


sub get_quotes_contain {
    my ( $self, $arg_ref ) = @_;


    my $contain = q{};
    if ($arg_ref->{'Contain'}) {
        $contain = _rm_beg_end_space($arg_ref->{'Contain'});
    }
    else {
        croak 'Contain is a mandatory parameter';
    }

    _args_are_valid($arg_ref, [qw/Contain Rating AttrName Limit/]);

    my ($lower, $upper) = (q{}, q{});
    if ($arg_ref->{'Rating'}) {
        ($lower, $upper) = _get_rating_params($arg_ref->{'Rating'});
    }

    my $limit = q{};
    if ($arg_ref->{'Limit'}) {
        $limit = _rm_beg_end_space($arg_ref->{'Limit'});
    }

    # default use case for attribution, return random quote
    my $attr_name = q{};
    if ( $arg_ref->{'AttrName'} ) {
        # return 'n' from random from specified pool
        $attr_name = _rm_beg_end_space($arg_ref->{'AttrName'});
    }

    return _get_rand_quote_for_attribution($attr_name, $lower, $upper, $limit, $contain);
}

1 and 'Chief Wiggum: Uh, no, you got the wrong number. This is 9-1... 2.';


 view all matches for this distribution


( run in 1.213 second using v1.00-cache-2.02-grep-82fe00e-cpan-1925d2aa809 )