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


A1z-HTML5-Template

 view release on metacpan or  search on metacpan

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

package A1z::HTML5::Template;
use strict;
use warnings;
use vars qw($NAME);

# ABSTRACT: Fast and Easy Web Apps

sub NAME { my $self = shift; $NAME = "Fast and Easy Web Apps"; return $NAME; }

our $VERSION = '0.22';

use parent qw(Exporter); 
require Exporter; 
our @ISA = ("Exporter"); 

our @EXPORT_OK = qw(header start_html head_title head_meta head_js_css end_head begin_body body_js_css body_topnavbar 
body_accordion end_body end_html head body
); 



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]-->
};

}



sub html_navbar 
{
	#my $self = shift; 

	#serverName, pageName, menuName, dropDownLinks
	
	my %in;
	%in = (
		-nbMenuName 	=>	"", 
		-nbPageName 	=> 	"",
		-nbServer    =>  "",
		-nbLinks => "blog-support-help-contact-sale",
		@_,		
	);
	
	return qq{<script src="https://www.a1z.us/js/utils/top-nav-bar.js"></script>
<!--top nav bar begin-->
<script>
//<-- 
fixed_top_navbar('$in{-nbServer}', '$in{-nbPageName}', '$in{-nbMenuName}', '$in{-nbLinks}');
//-->
</script>
<!-- top nav bar end--> 
}; 

}


 

sub html_bootstrap_js  
{
	# jquery:3.3.0 ui:1/12/1

	return qq{<!-- Bootstrap/jqueryUI -->
<link href="https://maxcdn.bootstrapcdn.com/bootstrap/3.3.0/js/bootstrap.min.js" rel="stylesheet" type="text/css">

}; 

}

sub html_js_css 
{
	
}

sub html_jquery 
{
	
}



sub html_setTitle 
{
	my $out;

	my %in;
	
	%in = (
		ta => qq{},
		tb => qq{},
		tc => qq{},
		@_,
	);

	$out .= qq{<script>		
<!-- Begin
	function setTitle() 
	{
		var a = "$in{ta}";
		var b = "$in{tb}";
		var c = "$in{tc}";
		var t = new Date();
		s = t.getSeconds();
		if (s == 10) { document.title = a;}
		else if (s == 20) { document.title = b;}
		else if (s == 30) { document.title = c;}
		else if (s == 40) { document.title = a;}
		else if (s == 50) { document.title = b;}
		else if (s == 00) { document.title = c;}
		setTimeout("setTitle()", 1000);
	}
//  End -->
</script>
	};

	return $out; 
}




sub html_humanejs_css
{
	return qq{<link rel='stylesheet' href='https://cdnjs.cloudflare.com/ajax/libs/humane-js/3.2.2/themes/bigbox.css'>
      <link rel='stylesheet' href='https://cdnjs.cloudflare.com/ajax/libs/humane-js/3.2.2/themes/boldlight.css'>
      <link rel='stylesheet' href='https://cdnjs.cloudflare.com/ajax/libs/humane-js/3.2.2/themes/jackedup.css'>
      <link rel='stylesheet' href='https://cdnjs.cloudflare.com/ajax/libs/humane-js/3.2.2/themes/libnotify.css'>
      <link rel='stylesheet' href='https://cdnjs.cloudflare.com/ajax/libs/humane-js/3.2.2/themes/original.css'>
<link rel='stylesheet' href='https://cdnjs.cloudflare.com/ajax/libs/humane-js/3.2.2/themes/flatty.min.css'>
<link href='https://fonts.googleapis.com/css?family=Ubuntu&v2' rel='stylesheet' type='text/css'>
<link href='https://fonts.googleapis.com/css?family=Ubuntu+Mono' rel='stylesheet' type='text/css'>
<link href='https://fonts.googleapis.com/css?family=Cabin+Sketch:700&v2' rel='stylesheet' type='text/css'>
}; 

}




sub html_bootstrap_bluimp 
{
	return qq{<!-- The Bootstrap Image Gallery lightbox, should be a child element of the document body -->
		<div id="blueimp-gallery" class="blueimp-gallery blueimp-gallery-controls" data-use-bootstrap-modal="false">
	    <!-- The container for the modal slides -->
	    <div class="slides"></div>
	    <!-- Controls for the borderless lightbox -->
	    <h3 class="title"></h3>
	    <a class="prev">‹</a>
	    <a class="next">›</a>
	    <a class="close">×</a>
	    <a class="play-pause"></a>
	    <ol class="indicator"></ol>
	    <!-- The modal dialog, which will be used to wrap the lightbox content -->
	    <div class="modal fade">
	        <div class="modal-dialog">
	            <div class="modal-content">
	                <div class="modal-header">
	                    <button type="button" class="close" aria-hidden="true">&times;</button>
	                    <h4 class="modal-title"></h4>
	                </div>
	                <div class="modal-body next"></div>
	                <div class="modal-footer">
	                    <button type="button" class="btn btn-default pull-left prev">
	                        <i class="glyphicon glyphicon-chevron-left"></i>
	                        Previous
	                    </button>
	                    <button type="button" class="btn btn-primary next">
	                        Next
	                        <i class="glyphicon glyphicon-chevron-right"></i>
	                    </button>
	                </div>
	            </div>
	        </div>
	    </div>
	</div>
	};
}
# end sub html_bootstrap_bluimp 




sub head 
{
	my $self = shift; 
	
	my $out; 
	
	my %in = (
		-type 	=> "Content-Type: text/html;charset=utf-8\n\n", 
		-bootstrap 	=> html_bootstrap_css, 
		-jqueryui 	=> html_jqueryui_css, 
		-htmlshim	=> html_shim_respond, 
		-humanejs  => html_humanejs_css, 
		-title 		=> "A1Z .us", 
		-cssLinks => "https://code.jquery.com/ui/1.11.4/themes/ui-lightness/jquery-ui.css,https://blueimp.github.io/Gallery/css/blueimp-gallery.min.css,https://www.a1z.us/A1z/HTML5/Template.css", 
		-cssCode => "", 
		-mobilemeta => qq{<meta name="HandheldFriendly" content="true">
<meta name="viewport" content="width=device-width, initial-scale=1.0">
}, 
		-charsetmeta => qq{<meta charset="utf-8">}, 
		-usermeta => "",
		-titleRotatingText => qq{text1,text2,text3},
		@_,
		
	); 


# rotating title function and text 
my $setTitle;
if ( $in{-titleRotatingText} and $in{-titleRotatingText} =~ /\,/ )
{
	my @a;
	@a = split(/\,/, $in{-titleRotatingText}, 3);

	$setTitle = html_setTitle(ta => "$a[0]", tb => "$a[1]", tc => "$a[2]");
}
else
{
	$setTitle = html_setTitle(ta => "Text01", tb => "text02", tc => "text03");
}

# css multiple links/files 
my $css; my @css; 
if ($in{-cssLinks} )
{
	if  ( $in{-cssLinks} =~ /\,/ ) 
	{
		@css = split(/\,/, $in{-cssLinks});
		for (@css) 
		{
			if ($_ =~ /\.css$/) 
			{
				$css .= qq{<link type="text/css" rel="stylesheet" href="$_">\n} ; 
			}
			else 
			{
				$css = ''; 
			}
		}
	}
}
else 
{
	$css = qq{}; 
}


	return qq{$in{-type}<!DOCTYPE html>
<html>
<head>
<title>$in{-title}</title> 
$in{-charsetmeta}
$in{-mobilemeta}
$in{-usermeta}
$in{-bootstrap} 
$in{-jqueryui} 
$in{-htmlshim} 
$in{-humanejs}
$css
<style type="text/css">
$in{-cssCode}
</style>

$setTitle

</head>
}; 	# thats orderly 

}
# end head 



sub body 
{
	my $self = shift; 
	
	my $out; 
	
	my %in; 
	
	%in = (
		-h1 => qq{A1Z .us},
		-onload => qq{setTitle();},  
		-nbhead => qq{},
		-nbpage => qq{}, 
		-nbmenu => qq{More}, 
		-defaultjquery => qq{$HTML{-defaultjquery}}, 
		-humanejs => qq{<script src="https://cdnjs.cloudflare.com/ajax/libs/humane-js/3.2.2/humane.min.js">},
		-userjquery => qq{}, 
		-navbar => html_navbar( $in{-nbmenu}, $in{-nbpage}, "", ""), 
		-content => qq{<div class="content">Content</div>}, 
		-footer => qq{All rights reserved &copy; A1Z .us}, 	
		-bootstrapbluimp => html_bootstrap_bluimp,
		-nbLinks => qq{contact-help-feedback},
		@_, 		
	); 
	
	return qq{<body onload="$in{-onload}">
<div id="main" class="container">
	<!--top nav bar begin-->
	<script  src="https://www.a1z.us/js/utils/top-nav-bar.js"></script>
	<script >
	//<-- 
	fixed_top_navbar('$in{-nbhead}', '$in{-nbpage}', '$in{-nbmenu}', '$in{-nbLinks}');
	//-->
	</script>

	$in{-bootstrapbluimp}

	$in{-h1}

	$in{-content}
	
	$in{-footer}

</div>

$in{-defaultjquery}

$in{-humanejs}
 
<script>
//<!--
$in{-userjquery}
//--> 
</script>

</body>
	
</html>
	
}; 

}
# end body 





sub open_file 
{
	my $self =shift;



	my %in;
	%in = 
	(
		file => "",
		
		output_header => "",

		output_format => "",

		@_,
	);

	my $file = "$in{file}" || "$_[0]"; 
	
	my $output_format = "$in{output_format}" || "$_[1]"; 	
	
	my $output_header = "$in{output_header}" || "$_[2]"; 
	
	my $out; 

	my $div4tabs;
	
	my @data; 
	
	if (-e -f "$file")
	{ 

		open(FILE, "$file") or die "$!";

		$out .= qq{\n<!--begin file output-->\n<div class="file_output">\n}; 
		
		# Step 1 
		# set the header as per format  
		if ($output_format eq 'table') 
		{ 
			$out .= qq{<table class="table table-striped table-bordered table-hover table-condensed table-responsive">
				<thead>
					<tr><th colspan="2">$output_header</th></tr>
				</thead>
				<tbody>
			}; 
		}
		elsif ($output_format eq 'accordion')
		{
			$out .= qq{<h2>$output_header</h2>\n<div id="accordion2" class="accordion"><!--118-->\n};
		} 
		elsif ($output_format eq 'menu') 
		{
			$out .= qq{<ul class="menu" id="menu">\n<li><a href="/">$output_header</a>\n<ul>};
		}
		elsif ($output_format eq 'tabs')
		{
			# special case for tabs since the data needs to be formatted a little differently 
			
			$out .= qq{<h2>$output_header</h2>\n<div id="tabs">\n<ul>\n};
			
			my $sl = '0'; 
			
				while ( my $line = <FILE>) 
				{
					$sl++ if $line; 
					
					my ($h1, $div) = (''); 
					
					if ($line =~ /\|/) 		
					{ 
						($h1, $div) = split(/\|/, $line, 2); 
					} 			# no (\|) # i.e., do not enclose with brackets
					elsif ($line =~ /\t+/) { 
						($h1, $div) = split(/\t+/, $line, 2); 
					} 
					elsif ($line =~ /\s+/) 
					{ 
						($h1, $div) = split(/\s+/, $line, 2); 
					}
					
					# Keep only those items that have '==' in the beginning  

					if ( $h1 =~ /^\s+/ or $div =~ /^\s+/ ) 
					{
						next unless ($h1 =~ /^\s+==/ or $div =~ /^\s+==/);
						$div =~ s!^\s+==!!g;
						$h1 =~ s!^\s+==!!g;
					}
					else
					{
						next unless ($h1 =~ /^==/ or $div =~ /^==/);
						$div =~ s!^==!!g;
						$h1 =~ s!^==!!g;
					}
				
					$out .= qq{\t<li><a href="#tabs-$sl">$h1</a></li>\n}; 

					$div4tabs .= qq{<div id="tabs-$sl">$div</div>};
				}
			$out .= qq{</ul>\n}; 

			$out .= $div4tabs;

			close FILE;
		}
		elsif ($output_format eq 'dialog')
		{
			$out .= qq{<h2>Dialog: <a href="#opener" id="opener" title="Opens the Dialog">$output_header</a></h2>
<div id="dialog">\n}; 
		}
		else 
		{
			$out .= qq{\n<h2>$output_header</h2>\n}; 
		}
		# End Step 1
		
		# now work on file 
		
		my $serial = '0'; 
		
		while ( my $line = <FILE> ) 
		{ 
			chomp $line; 
			
			$serial++ if $line; 
			
			my ($h1, $div) = (''); 
			
			if ($line) 				# make sure no output if line is empty
			{	
				$line =~ s! RN !\r\n!g;
				
				# split the file's lines into usable data according to separator used.
				if ($line =~ /\|/) 		
				{ 
					($h1, $div) = split(/\|/, $line, 2); 
				} 			# no (\|) # i.e., no enclosing with brackets.  was the culprit 
				elsif ($line =~ /\t+/) { 
					($h1, $div) = split(/\t+/, $line, 2); 
				} 
				elsif ($line =~ /\s+/) 
				{ 
					($h1, $div) = split(/\s+/, $line, 2); 
				}
				# end split the file's line according to match: 3 options: |, \t+, or \s+ 

			}
			
			# Step 2 
			#Now set the content as per output format 
			if ($output_format eq 'table') 
			{ 
				# Keep only those items that have a # in the beginning 
				 
				if ( $h1 =~ /^\s+/ or $div =~ /^\s+/ ) 
				{
					next unless ($h1 =~ /^\s+#/ or $div =~ /^\s+#/);
					$div =~ s!^\s+#!!g;
					$h1 =~ s!^\s+#!!g;
				}
				else
				{
					next unless ($h1 =~ /^#/ or $div =~ /^#/);
					$div =~ s!^#!!g;
					$h1 =~ s!^#!!g;
				}
				$out .= qq{\t<tr><td>$h1</td><td>$div</td></tr>\n}; 
			}
			elsif ($output_format eq 'accordion')
			{
				# Keep only those items that have -- in the beginning 
					
				if ( $h1 =~ /^\s+/ or $div =~ /^\s+/ ) 
				{
					next unless ($h1 =~ /^\s+--/ or $div =~ /^\s+--/);
					$div =~ s!^\s+--!!g;
					$h1 =~ s!^\s+--!!g;
				}
				else
				{
					next unless ($h1 =~ /^--/ or $div =~ /^--/);
					$div =~ s!^--!!g;
					$h1 =~ s!^--!!g;
				} 
				
				$out .= qq{\t<h3>$h1</h3>\n\t<div>$div</div>\n} if $line; 
			} 
			elsif ($output_format eq 'menu') 
			{
				# the first item will be used as link title and name
				# the second item will be used as the actual link  
				# no extensions added automatically by the script 
				# an id for each link/li is also provided in case, may be it is not needed 
				
				# Remove items with a # in the beginning; Sat Feb 21 18:48:19 2015
				next if ($h1 =~ /^#http/ or $div =~ /^#http/); 
				
				# Keep only those items that have a 'http' in the beginning 
				 
				if ( $h1 =~ /^\s+/ or $div =~ /^\s+/ ) 
				{
					next unless ($h1 =~ /^\s+http/ or $div =~ /^\s+http/);					
					#$div =~ s!^\s+http!!g;
					#$h1 =~ s!^\s+http!!g;
				}
				else
				{
					next unless ($h1 =~ /^http/ or $div =~ /^http/);
					#$div =~ s!^http!!g;
					#$h1 =~ s!^http!!g;
				}
				$out .= qq{\t<li id="li-$serial"><a id="a-$serial" href="$div" title="$h1">$h1</a></li>\n};
			}
			elsif ($output_format eq 'tabs') 
			{
				# Keep only those items that have a == in the beginning  
				
				if ( $h1 =~ /^\s+/ or $div =~ /^\s+/ ) 
				{
					next unless ($h1 =~ /^\s+==/ or $div =~ /^\s+==/);
					$div =~ s!^\s+==!!g;
					$h1 =~ s!^\s+==!!g;
				}
				else
				{
					next unless ($h1 =~ /^==/ or $div =~ /^==/);
					$div =~ s!^==!!g;
					$h1 =~ s!^==!!g;
				}
				
				# Mismatching fragment identifier. See 1797.
				# $div not available here as <FILE> is not open here.
				$out .= qq{\t<div id="tabs-$serial"><p>$div</p></div>\n}; 
				
			}
			elsif ($output_format eq 'dialog')
			{
				# includes everything; So, no filtering.
				
				# But, just remove symbols in both $h1 and $div
				$div =~ s!^(==|\#|--)!!g;
				$h1 =~ s!^(==|\#|--)!!g;
					
				$out .= qq{\t\t<h4 class="dialog-header">$h1</h4>\n\t\t<div class="dialog-content">$div <hr/></div>\n}; 
			}
			else 
			{
				$out .= qq{$h1 $div}; 	# or $line
			}
		} 
		
		# add an extra item at the end of file output 
		
		# Step 3 
		# set the output ending as per format  
		if ($output_format eq 'table') 
		{ 
			$out .= qq{\n</tbody>\n</table>\n\n}; 
		}
		elsif ($output_format eq 'accordion')
		{
			$out .= qq{\n<!--end accordion--></div>\n\n};
		} 
		elsif ($output_format eq 'menu') 
		{
			$out .= qq{</ul></ul>};
		}
		elsif ($output_format eq 'tabs')
		{
			$out .= qq{</div><!--end tabs-->\n}; 
		}
		elsif ($output_format eq 'dialog') 
		{
			$out .= qq{</div><!--end dialog-->\n}; 
		}
		else 
		{
			$out .= qq{\n\n}; 
		}
		
		# end file output wrapper
		$out .= qq{</div><!--end file output-->\n};  
		
		return $out; 
	}
	else 
	{
		my $out;

		
	
		$out .= qq{\n<!--begin accord 112-->\n<div id="accordion1460" class="accordion">\n}; 
		while ( my $line = <FILE> ) 
		{ 
			chomp $line; 
			
			my ($h1, $div) = (''); 
			
			($h1, $div) = split(/\t+/, $line, 2) if $line; 
			
			$out .= qq{\t<h3>$h1</h3>\n\t<div>$div</div>\n} if $line; 
		} 
		$out .= qq{\t<h3>Powered by</h3>\n\t<div>Perl/CPAN</div>\n}; 
		
		$out .= qq{</div>\n<!--end accord-->\n}; 
		
		return $out; 
	}

	close FILE;
	
}
# end open_file




sub edit_file
{
	my $self = shift;
	
	my $out;
	
	my %in;
	
	%in = (
		file => "",
		error => "",
		action => "TemplateAdmin.cgi",
		serial => '', 
		output_type => '',
		@_,
	);
	
	if (-e -f "$in{file}")
	{
		open(FILE, "$in{file}") or $in{error} = "unable to open $in{file}";
		my @file = <FILE>;
		close FILE;
		
		$out .= qq{
		<article class="container">
			
			<form action="$in{action}" method="post">
			<input type="hidden" name="action" value="write">
		};
		
		for (@file)
		{
			chomp;
			
			next if $_ =~ /^$/;
			
			$in{serial}++ if $_;
			
			my ( $type, $content ) = split(/\|/, $_, 2);
			
			$type =~ s!\s+$!!g;
			
			my $identifiers = substr "$content", 0, 4;	# has to be 4 to cover 'http.'  Also, assuming no spaces in the beginning (removed by write_file)
			
			# determine output type
			if ( $identifiers =~ /^\#/ ) { $in{output_type} = 'Table'; }
			elsif ( $identifiers =~ /^\-/ ) { $in{output_type} = 'Accordion'; }
			elsif ( $identifiers =~ /^\=/ ) { $in{output_type} = 'Tabs'; }
			elsif ( $identifiers =~ /^http/ ) { $in{output_type} = 'Menu'; }
			else { $in{output_type} = 'None'; }
			
			# remove all nonmeta characters for web page display 
			$identifiers =~ s!(\s+|[a-zA-z0-9])!!g;	# removes http also.
			
			$content =~ s!\<!&lt\;!g;
			$content =~ s!\>!&gt\;!g;
			
			$content =~ s! RN !\r\n!g; # &#13;&#10;
			
			$out .= qq`<div>
				<span class="serial">$in{serial} </span> 
				<span class="type">$type </span> 
				<span class="identifiers">$identifiers </span>
				<span class="type type-$in{output_type}">Type:$in{output_type} </span>
			</div>
			<div>
				<textarea name="ta-$type" id="ta-$type" rows="5" cols="98%" class="type-$in{output_type}">$type , $content</textarea>
			</div>
				<br/>
			`;
		}
		
		$out .= qq{<input type='submit' value="Save"></form></article>};
		
		
		return $out;
		
	}
}



sub write_file
{
	my $self = shift;
	
	my $out; 
	
	my %in;
	%in = 
	(
		file => "",
		error => "",
		powershell => "C:/WINDOWS/system32/WindowsPowerShell/v1.0/powershell.exe ",
		@_,
	);
	
	my %vars;
	
	use CGI;
	my $q = new CGI;
	%vars = $q->Vars();
	
	my $action = $q->param('action');
	
	if ( $action eq 'write')
	{

		if (-e -f "$in{file}")
		{
			
			# First, get file content to backup to another file
			open(F, "$in{file}") or $in{error} .= "#1565 Unable to open file for reading. '$!' <br/>";
			my @f = <F>;
			
			# save original file content to backup file
			open(BAK, ">$in{file},bak.txt") or $in{error} .= "#1570 Unable to create backup file '$in{file},bak.txt' '$!' <br/>";
			for (@f)
			{
				print BAK qq{$_};	
			}
			close BAK;
			
			close F;
			
			# recreate file, thereby deleting original content 
			open(DEL, ">$in{file}") or $in{error} .= "#1579 Unable to recreate file '$in{file}' '$!' <br/>";
			print DEL "File ReCreated";
			close DEL;
			
			my %out;
			for (keys %vars)
			{
				chomp $_; 
				chomp $vars{$_}; 
				
				next if $_ eq 'action';
				my ( $name, $value ) = split(/\,/, $vars{"$_"}, 2);
				
				$name =~ s!(\r\n+|\n+)! RN !g;
				$value =~ s!(\r\n+|\n+)! RN !g;
				
				$value =~ s!^\s+!!g;
				
				$out{"$name"} = "$value";
			}			
			
			# Insert/Add new content
			open(FILE, ">$in{file}") or $in{error} .= "#1582 Error writing to file '$in{file}' '$!' <br/>";			
			for (keys %out) 
			{
				print FILE qq{$_\|$out{$_}\n};
			}
			close FILE;
			
			
			if (-e -f "$in{file},bak.txt" and -e -f "$in{file}")
			{	
				return "<div class='success'>Saved</div> <div class='error'>$in{error}</div>";
			}
			else
			{
				return "<div>#1605 Error saving file '$in{file}'</div> <div class='error'>$in{error}</div>";
			}
		}
		else
		{
			return "File not found";
		}
	}
	elsif ( $action eq 'newItem' )
	{
		return "$action";
	}
	else
	{
		return '* ' x 10;
	}
	
}

# end write_file




sub display_gallery_thumbnails
{
	my $self = shift;

	my $out;

	my %in;

	%in = (
		
		error => "",

		images_dir => "/images/a1z-html5-template/",
		thumbs_dir => "/images/a1z-html5-template/thumbs",
		
		images_url => "/images/a1z-html5-template",
		thumbs_url => "/thumbs/a1z-html5-template/thumbs",

		width => "100",
		height => "100",

		@_,
	);

	if (-e -d "$in{images_dir}" and "$in{thumbs_dir}" )
	{
		opendir(TH, "$in{thumbs_dir}") or $in{error} .= qq{<p>$!</p>};
		my @thumbs = readdir(TH);
		close TH;

		foreach ( @thumbs ) 
		{
			if ( $_ and $_ =~ /(.jpg|.gif|.jpeg|.png|.tiff)$/ )
			{
				$out .= qq{\n<a href="$in{images_url}/$_" title="$_" data-gallery> <img src="$in{thumbs_url}/$_" alt="Image $_" width="$in{width}" height="$in{height}"> </a> \n};
			}
		}
	}
	else
	{
		$in{error} .= qq{<p>Image directory does not exist or is inaccessible. Make sure you provided the correct path.</p>};

		$out = $in{error};
	}

	return $out;
}
# end display gallery thumbnails 









1;

__END__

=pod

=encoding UTF-8

=head1 NAME

A1z::HTML5::Template - Fast and easy Web Apps

=head1 VERSION

version 0.22

=head1 SYNOPSIS

    use A1z::HTML5::Template;
    my $h = A1z::HTML5::Template->new();

    This directory should be writable by the web server, required to create/hold page content files.
	This may also contain your custom JavaScript/CSS libraries.
	Works for both Windows and Linux
	
		use lib '/home/user/path/to/app';
		or
		use lib 'C:/Inetpub/wwwroot/path/to/app';

	# for features like 'say'
	use 5.10.0;

	my $h = A1z::HTML5::Template->new(); 

	Fast, Easy, and Simple: Just Two Lines!
	
		say $h->head( -title => "My Brand Name" );
		say $h->body( -content => qq{ Coming Soon });

	For More Control/Customization: Not for the lazy!
	
	say $h->header('utf8');  
	say $h->start_html(); 
	say $h->head_title("My New App"); 
	say $h->head_meta(); 

	Load basic/required JavaScript/CSS libraries
	say $h->head_js_css(); 

	Add your own custom JavaScript/CSS files
	say $h->head_js_css('/url/to/app/Template.css'); 

	say $h->end_head(); 
	say $h->begin_body();

	say qq{<h1>My New App/Website</h1>};

	say qq{<main class="container">}; 

		# output file content as menu
		say $h->body_accordion( $h->open_file("/home/user/path/to/app/open_file_example.txt", 'menu', 'Menu') ); 

		# as a HTML5 table 
		say $h->body_accordion( $h->open_file("$sys{cgibase}/open_file_example.txt", 'table', 'Table Header') );
		
		# Simple mathematics 
		say $h->body_article( header => "Simple Mathematics", content => $h->math1("2", "4") );

		# Times Table  
		say $h->body_article( header => "Times Table", content => $h->timestable("2") );

	say qq{</main>};

	Required/Default JavaScript libraries.
		say $h->body_js_css(); 
	
	Add your own JavaScript libraries:
		say $h->body_js_css("complete-url_or_path-to-js-css-libraries")	

	say $h->end_body();
	say $h->end_html(); 

=head1 NAME

	Fast and Easy Web Apps

	"A1z::HTML5::Template" provides customizable HTML5 tags for creating "Fast and Easy Web Apps."

=head2 VERSION

	0.22

=head1 Installation

	cpan install A1z::HTML5::Template 
	or
	cpanm A1z::HTML5::Template

=head1 METHODS

	header start_html head_title head_meta head_js_css end_head begin_body body_js_css body_topnavbar body_accordion end_body end_html 

=head2 new

   use A1z::HTML5::Template;
   my $h = A1z::HTML5::Template->new();

=head2 math1

	$h->math1(num1, num2);
	
	$h->body_article( header => "Math", content => $h->math1(num1, num2) );

=head2 timestable

	$h->timestable("Number");

=head2 header

	Provides HTML Content-Header 
	
	$h->header("");

=head2 start_html

	Provides doctype html
	
	Default includes utf-8

		$h->start_html();
	
	Or, add your own charset to your app:

		$h->start_html('DifferentCharset');

=head2 body_js_css

	Add/include javascript and css files just above </body> section 
	
	Typically, CSS files should/are not be used here. 
	
	Default behavior: 
	
		$h->body_js_css();
		
		Includes 
			jquery 1.12.4, jquery ui 1.11.4, bootstrap 3.3.0, 
			javascript for #dialog function, #menu, #accordion, #tabs 
	
	Add your own .js file: 
		
		use $h->body_js_css("/path/to/js/file.js");
		
	You can use both to include default .js files and your own custom .js file. 

=head2 end_html 

	Provides </html>

=head2 head_title

	Provides <title></title>
	
	$h->head_title("App/Page Title");

=head2 head_meta

	Provides <meta ... >. Includes the following by default:
		IE=Edge
		HandheldFriendly
		viewport
	
	$h->head_meta();
	
	Just like body_js_css, you can use both to add default values and your own meta 

=head2 body_topnavbar

	Provides top nav bar optionally.
	
	By default it is loaded from www.a1z.us which probably be removed in a future version.
	So, get a copy from bootstrap 3 and store it on your server.

=head2 head_js_css

	provides the ability to add/include .js/.css files in the </head> tag.
	
	$h->head_js_css();
	
		Default includes the following:
		
			bootstrap 3.3.0 .css from maxcdn 
			navbar-fixed-top.css from www.a1z.us
			jquery 1.12.1 smoothness theme from code.jquery.com 
			Shim and Respond.js from maxcdn 
	
	$h->head_js_css("/path/to/.js")
	$h->head_js_css("/path/to/.css")

=head2 end_head

	Provides </head>
	
	$h->end_head();

=head2 begin_body

	provides <body> tag.
	
	$h->begin_body();

=head2 body_accordion

	The accordion in 'body_accordion' is misleading. It is not limited to just an accordion but all kinds of content.

	C<say $h->body_accordion( $h->open_file("/path/to/app/open_file_example.txt", 'Type', 'Heading') );>

	C<say $h->body_accordion( $h->open_file("/path/to/app/open_file_example.txt", "table", "Name and Price");

	C<say $h->body_accordion( $h->open_file("/path/to/app/open_file_example.txt", "tabs", "Space Saving Tabs");

=head2 body_article

	provides the ability to add content into <main> tags. 
	
	$h->body_article( header => "", content => "");

=head2 end_body

	provides </body> tag.
	
	$h->end_body();

=head2 body_form

	Form, lists items from a directory in a neat drop-down list with each item's file size in KB!

	Should be in the exact format like below: 
	
	$h->body_form("vars;METHOD;Action.cgi;select,NameForSelectTag,DefaultOptionSelected,AbsPathToDir,TextForSelectLabel;hidN1---hidV1,hidN2---hidV2,hidN3---hidV3");

=head2 defaults_begin

	Internal Use Only

	Provides defaults for very lightweight template for those in a hurry; Can be used for apps/sites that are under construction! 
	
	$h->defaults_begin();

=head2 defaults_end

	Internal Use Only.

	provides defaults for lightweight or under construction app/website. 
	
	$h->defaults_end();

=head1 HTML Hash

	For Internal/Future Use

	Hash contains -defaultjquery which is used in body.

	-defaultjquery includes 
		
		jquery                1.12.4       from code.jquery
		jquery ui             1.11.4       
		bootstrap             3.3.0        from maxcdn
		blueimp-gallery
		ie-10 workaround                   from a1z.us
		
		functions
		
			tabs, dialog, menu, accordion

=head2 html_bootstrap_css 

	For Internal/Future Use

	Used in $h->head and $h->body internally.

	All methods starting with 'html_' are used internally!

	Include bootstrap.min.css, #3.3.0 from maxcdn and navbar-fixed-top.css from a1z.us
		
		$h->html_bootstrap_css()

=head2 html_jqueryui_css

	For Internal/Future Use

	Includes jquery ui theme jquery-ui.css #1.12.0

=head2 html_shim_respond

	For Internal/Future Use

	html5shiv.min.js   #3.7.2
	respond.min.js     #1.4.2

=head2 html_navbar

	For Internal/Future Use

	Customizations for top-nav-bar.js from a1z.us

	$h->html_navbar(
		-nbMenuName => "menuName", 
		-nbPageName => "pageName", 
		-nbServer => "serverName", 
		-nbLinks => "dropDownLinks: URLs separated by a dash, mostly relative URLs. E.g., blog-support-help-contact-sale"
	);

=head2 html_bootstrap_js

	For Internal/Future Use

	bootstrap.min.js, #3.3.0, from maxcdn

=head2 html_setTitle 

	For Internal/Future Use

	setTitle javascript function 

	Used in body

	Includes the C<script> tag pair

	C<$h->html_set_title( ta => "Text001", tb => "TExt002", tc => "TeXt003" );>

=head2 html_humanejs_css

	For Internal/Future Use

	humane-js #3.2.2 cdnjs.cloudflare
	fonts.googleapis.com

=head2 html_bootstrap_bluimp

	For Internal/Future Use

	bootstrap gallery lightbox controls for use immediately after C<body> tag

	C<&html_bootstrap_bluimp;>

	Used internally in C<$h->body()> 

=head2 head

	$h->head();

	$h-head (
		-type 	=> "Content-Type: text/html;charset=utf-8\n\n", 
		-bootstrap 	=> html_bootstrap_css, 
		-jqueryui 	=> html_jqueryui_css, 
		-htmlshim	=> html_shim_respond, 
		-humanejs  => html_humanejs_css, 
		-title 		=> "A1Z .us", 
		-cssLinks => "https://code.jquery.com/ui/1.11.4/themes/ui-lightness/jquery-ui.css,https://blueimp.github.io/Gallery/css/blueimp-gallery.min.css,https://www.a1z.us/A1z/HTML5/Template.css", 
		-cssCode => "", 
		-mobilemeta => qq{<meta name="HandheldFriendly" content="true">
<meta name="viewport" content="width=device-width, initial-scale=1.0">
}, 
		-charsetmeta => qq{<meta charset="utf-8">}, 
		-usermeta => "",
		-titleRotatingText => qq{text1,text2,text3}	
	); 

=head2 body

	$h->body();

	$h->body(
		-h1	=> qq{A1Z .us},
		-onload => qq{setTitle();},  
		-nbhead => qq{},
		-nbpage => qq{}, 
		-nbmenu => qq{More}, 
		-defaultjquery => qq{$HTML{-defaultjquery}}, 
		-humanejs => qq{<script src="https://cdnjs.cloudflare.com/ajax/libs/humane-js/3.2.2/humane.min.js">},
		-userjquery => qq{}, 
		-navbar => html_navbar( $in{-nbmenu}, $in{-nbpage}, "", ""), 
		-content => qq{<div class="content">Content</div>}, 
		-footer => qq{All rights reserved &copy; A1Z .us}, 	
		-bootstrapbluimp => html_bootstrap_bluimp,
		-nbLinks => qq{contact-help-feedback}		
	); 

=head1 open_file

	Used for loading all kinds of custom elements for different output formats stored in simple text files.

	$h->open_file("/path/to/file", "outputFormat", "outputHeader");

	$h->open_file("C:/Inetpub/wwwroot/MyApp/menu.txt", "menu", "Menu");

	This is the heart of the App.

=head2 OUTPUT FORMAT OPTIONS: 

	table, accordion, menu, as is; where "as is" is the default

	$h->open_file( file => "abs/path/to/file", output_format => "table", output_header => "Heading" ); 

=head2 edit_file

	Edit your app/page/site. Customize HTML produced by A1z::HTML5::Template. 

	Creates a form to edit contents of a file. 

	The contents of this file should be in a special format. See open_file_example.txt. 

	Data is stored in simple text files in the app's home dir.  

	We recommend creating a separate file for editing/writing purposes, e.g., "TemplateAdmin.cgi"

	use lib '/path/to/app';

	use A1z::HTML5::Template;
	my $h = A1z::HTML5::Template->new();

	say $h->header('utf8');
	say $h->start_html(); 
	say $h->head_title("Edit App"); 
	say $h->head_meta();
	say $h->head_js_css();  
	say $h->end_head(); 
	say $h->begin_body();

	# Show edit form

 	say $h->body_article( 

		header => "Edit page items", 

		action => "TemplateAdmin.cgi",

		content => $h->edit_file( file => "/absolute/path/to/app/open_file_example.txt") 
	);

	# Save Customizations back to the same file.

	# include write_file if you submit form to the same file ( TemplateAdmin.cgi )

	say $h->body_article( 

		header => "<a href='$sys{cgiurl}/TemplateAdmin.cgi' title='Refresh to get the latest/saved content'>Refresh</a> ", 

		content => $h->write_file( file => "/absolute/path/to/app/open_file_example.txt")
	 
	);

	say $h->body_js_css(); 
	say $h->end_body();
	say $h->end_html(); 

=head2 write_file

	See documentation for 'edit_file.'

=head2 display_gallery_thumbnails

	my $images = $h->display_gallery_thumbnails(

		images_dir => "{images_dir}",
		thumbs_dir => "{thumbs_dir}",
		
		images_url => "{images_url}",
		thumbs_url => "{thumbs_url}",

		width => "100",
		height => "100"
	);

=head1 BUGS

Please report any bugs or feature requests to C<bug-a1z-html5-template at rt.cpan.org>, or through
the web interface at L<https://rt.cpan.org/NoAuth/ReportBug.html?Queue=A1z-HTML5-Template>.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc A1z::HTML5::Template

You can also look for information at:

=over 4

=item * RT: CPAN's request tracker (report bugs here)

L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=A1z-HTML5-Template>

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/A1z-HTML5-Template>

=item * CPAN Ratings

L<https://cpanratings.perl.org/d/A1z-HTML5-Template>

=item * Search CPAN

L<https://metacpan.org/release/A1z-HTML5-Template>

=back

=head1 ACKNOWLEDGEMENTS

	I am greatly indebted to my family for letting me be 'addicted' and 'married' to my computers.

=head1 LICENSE AND COPYRIGHT

Copyright 2018 Sudheer Murthy.

This program is free software; you can redistribute it and/or modify it
under the terms of the the Artistic License (2.0). You may obtain a
copy of the full license at:

L<http://www.perlfoundation.org/artistic_license_2_0>

Any use, modification, and distribution of the Standard or Modified
Versions is governed by this Artistic License. By using, modifying or
distributing the Package, you accept this license. Do not use, modify,
or distribute the Package, if you do not accept this license.

If your Modified Version has been derived from a Modified Version made
by someone other than you, you are nevertheless required to ensure that
your Modified Version complies with the requirements of this license.

This license does not grant you the right to use any trademark, service
mark, tradename, or logo of the Copyright Holder.

This license includes the non-exclusive, worldwide, free-of-charge
patent license to make, have made, use, offer to sell, sell, import and
otherwise transfer the Package with respect to any patent claims
licensable by the Copyright Holder that are necessarily infringed by the
Package. If you institute patent litigation (including a cross-claim or
counterclaim) against any party alleging that the Package constitutes
direct or contributory patent infringement, then this Artistic License
to you shall terminate on the date that such litigation is filed.

Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER
AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES.
THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY
YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR
CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR
CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE,
EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

=head1 AUTHOR

Sudheer Murthy <pause@a1z.us>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2018 by Sudheer Murthy.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut

 view all matches for this distribution


A1z-Html

 view release on metacpan or  search on metacpan

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

use strict;
use warnings;
package A1z::Html;
use vars qw($NAME);

# ABSTRACT: Web Utilities

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__

=pod

=encoding UTF-8

=head1 NAME

Web Utilities - A1z::Html 

=head1 VERSION

version 0.04

=head1 SYNOPSIS

use A1z::Html;
    my $h = A1z::Html->new();
	my $welcome = A1z::Html->welcome();
	print $welcome;

=head1 AUTHOR

Sudheer Murthy <pause@a1z.us>

=head1 COPYRIGHT

This software is copyright (c) 2019 by Sudheer Murthy.

=head1 LICENSE

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut

 view all matches for this distribution


AAAA-Crypt-DH

 view release on metacpan or  search on metacpan

inc/Devel/CheckLib.pm  view on Meta::CPAN

# $Id: CheckLib.pm,v 1.25 2008/10/27 12:16:23 drhyde Exp $

package #
Devel::CheckLib;

use 5.00405; #postfix foreach
use strict;
use vars qw($VERSION @ISA @EXPORT);
$VERSION = '1.09';
use Config qw(%Config);
use Text::ParseWords 'quotewords';

use File::Spec;
use File::Temp;

require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(assert_lib check_lib_or_exit check_lib);

# localising prevents the warningness leaking out of this module
local $^W = 1;    # use warnings is a 5.6-ism

_findcc(); # bomb out early if there's no compiler

=head1 NAME

Devel::CheckLib - check that a library is available

=head1 DESCRIPTION

Devel::CheckLib is a perl module that checks whether a particular C
library and its headers are available.

=head1 SYNOPSIS

    use Devel::CheckLib;

    check_lib_or_exit( lib => 'jpeg', header => 'jpeglib.h' );
    check_lib_or_exit( lib => [ 'iconv', 'jpeg' ] );
  
    # or prompt for path to library and then do this:
    check_lib_or_exit( lib => 'jpeg', libpath => $additional_path );

=head1 USING IT IN Makefile.PL or Build.PL

If you want to use this from Makefile.PL or Build.PL, do
not simply copy the module into your distribution as this may cause
problems when PAUSE and search.cpan.org index the distro.  Instead, use
the use-devel-checklib script.

=head1 HOW IT WORKS

You pass named parameters to a function, describing to it how to build
and link to the libraries.

It works by trying to compile some code - which defaults to this:

    int main(int argc, char *argv[]) { return 0; }

and linking it to the specified libraries.  If something pops out the end
which looks executable, it gets executed, and if main() returns 0 we know
that it worked.  That tiny program is
built once for each library that you specify, and (without linking) once
for each header file.

If you want to check for the presence of particular functions in a
library, or even that those functions return particular results, then
you can pass your own function body for main() thus:

    check_lib_or_exit(
        function => 'foo();if(libversion() > 5) return 0; else return 1;'
        incpath  => ...
        libpath  => ...
        lib      => ...
        header   => ...
    );

In that case, it will fail to build if either foo() or libversion() don't
exist, and main() will return the wrong value if libversion()'s return
value isn't what you want.

=head1 FUNCTIONS

All of these take the same named parameters and are exported by default.
To avoid exporting them, C<use Devel::CheckLib ()>.

=head2 assert_lib

This takes several named parameters, all of which are optional, and dies
with an error message if any of the libraries listed can
not be found.  B<Note>: dying in a Makefile.PL or Build.PL may provoke
a 'FAIL' report from CPAN Testers' automated smoke testers.  Use 
C<check_lib_or_exit> instead.

The named parameters are:

=over

=item lib

Must be either a string with the name of a single 
library or a reference to an array of strings of library names.  Depending
on the compiler found, library names will be fed to the compiler either as
C<-l> arguments or as C<.lib> file names.  (E.g. C<-ljpeg> or C<jpeg.lib>)

=item libpath

a string or an array of strings
representing additional paths to search for libraries.

=item LIBS

a C<ExtUtils::MakeMaker>-style space-separated list of
libraries (each preceded by '-l') and directories (preceded by '-L').

This can also be supplied on the command-line.

=item debug

If true - emit information during processing that can be used for
debugging.

=back

And libraries are no use without header files, so ...

=over

=item header

Must be either a string with the name of a single 
header file or a reference to an array of strings of header file names.

=item incpath

a string or an array of strings
representing additional paths to search for headers.

=item INC

a C<ExtUtils::MakeMaker>-style space-separated list of
incpaths, each preceded by '-I'.

This can also be supplied on the command-line.

=item ccflags

Extra flags to pass to the compiler.

=item ldflags

Extra flags to pass to the linker.

=item analyze_binary

a callback function that will be invoked in order to perform custom
analysis of the generated binary. The callback arguments are the
library name and the path to the binary just compiled.

It is possible to use this callback, for instance, to inspect the
binary for further dependencies.

=back

=head2 check_lib_or_exit

This behaves exactly the same as C<assert_lib()> except that instead of
dieing, it warns (with exactly the same error message) and exits.
This is intended for use in Makefile.PL / Build.PL
when you might want to prompt the user for various paths and
things before checking that what they've told you is sane.

If any library or header is missing, it exits with an exit value of 0 to avoid
causing a CPAN Testers 'FAIL' report.  CPAN Testers should ignore this
result -- which is what you want if an external library dependency is not
available.

=head2 check_lib

This behaves exactly the same as C<assert_lib()> except that it is silent,
returning false instead of dieing, or true otherwise.

=cut

sub check_lib_or_exit {
    eval 'assert_lib(@_)';
    if($@) {
        warn $@;
        exit;
    }
}

sub check_lib {
    eval 'assert_lib(@_)';
    return $@ ? 0 : 1;
}

# borrowed from Text::ParseWords
sub _parse_line {
    my($delimiter, $keep, $line) = @_;
    my($word, @pieces);

    no warnings 'uninitialized';  # we will be testing undef strings

    while (length($line)) {
        # This pattern is optimised to be stack conservative on older perls.
        # Do not refactor without being careful and testing it on very long strings.
        # See Perl bug #42980 for an example of a stack busting input.
        $line =~ s/^
                    (?:
                        # double quoted string
                        (")                             # $quote
                        ((?>[^\\"]*(?:\\.[^\\"]*)*))"   # $quoted
        | # --OR--
                        # singe quoted string
                        (')                             # $quote
                        ((?>[^\\']*(?:\\.[^\\']*)*))'   # $quoted
                    |   # --OR--
                        # unquoted string
                        (                               # $unquoted
                            (?:\\.|[^\\"'])*?
                        )
                        # followed by
                        (                               # $delim
                            \Z(?!\n)                    # EOL
                        |   # --OR--
                            (?-x:$delimiter)            # delimiter
                        |   # --OR--
                            (?!^)(?=["'])               # a quote
                        )
        )//xs or return;    # extended layout
        my ($quote, $quoted, $unquoted, $delim) = (($1 ? ($1,$2) : ($3,$4)), $5, $6);

        return() unless( defined($quote) || length($unquoted) || length($delim));

        if ($keep) {
            $quoted = "$quote$quoted$quote";
        }
        else {
            $unquoted =~ s/\\(.)/$1/sg;
            if (defined $quote) {
                $quoted =~ s/\\(.)/$1/sg if ($quote eq '"');
            }
        }
        $word .= substr($line, 0, 0); # leave results tainted
        $word .= defined $quote ? $quoted : $unquoted;

        if (length($delim)) {
            push(@pieces, $word);
            push(@pieces, $delim) if ($keep eq 'delimiters');
            undef $word;
        }
        if (!length($line)) {
            push(@pieces, $word);
        }
    }
    return(@pieces);
}

sub assert_lib {
    my %args = @_;
    my (@libs, @libpaths, @headers, @incpaths);

    # FIXME: these four just SCREAM "refactor" at me
    @libs = (ref($args{lib}) ? @{$args{lib}} : $args{lib}) 
        if $args{lib};
    @libpaths = (ref($args{libpath}) ? @{$args{libpath}} : $args{libpath}) 
        if $args{libpath};
    @headers = (ref($args{header}) ? @{$args{header}} : $args{header}) 
        if $args{header};
    @incpaths = (ref($args{incpath}) ? @{$args{incpath}} : $args{incpath}) 
        if $args{incpath};
    my $analyze_binary = $args{analyze_binary};

    my @argv = @ARGV;
    push @argv, _parse_line('\s+', 0, $ENV{PERL_MM_OPT}||'');

    # work-a-like for Makefile.PL's LIBS and INC arguments
    # if given as command-line argument, append to %args
    for my $arg (@argv) {
        for my $mm_attr_key (qw(LIBS INC)) {
            if (my ($mm_attr_value) = $arg =~ /\A $mm_attr_key = (.*)/x) {
            # it is tempting to put some \s* into the expression, but the
            # MM command-line parser only accepts LIBS etc. followed by =,
            # so we should not be any more lenient with whitespace than that
                $args{$mm_attr_key} .= " $mm_attr_value";
            }
        }
    }

    # using special form of split to trim whitespace
    if(defined($args{LIBS})) {
        foreach my $arg (split(' ', $args{LIBS})) {
            die("LIBS argument badly-formed: $arg\n") unless($arg =~ /^-[lLR]/);
            push @{$arg =~ /^-l/ ? \@libs : \@libpaths}, substr($arg, 2);
        }
    }
    if(defined($args{INC})) {
        foreach my $arg (split(' ', $args{INC})) {
            die("INC argument badly-formed: $arg\n") unless($arg =~ /^-I/);
            push @incpaths, substr($arg, 2);
        }
    }

    my ($cc, $ld) = _findcc($args{debug}, $args{ccflags}, $args{ldflags});
    my @missing;
    my @wrongresult;
    my @wronganalysis;
    my @use_headers;

    # first figure out which headers we can't find ...
    for my $header (@headers) {
        push @use_headers, $header;
        my($ch, $cfile) = File::Temp::tempfile(
            'assertlibXXXXXXXX', SUFFIX => '.c'
        );
        my $ofile = $cfile;
        $ofile =~ s/\.c$/$Config{_o}/;
        print $ch qq{#include <$_>\n} for @use_headers;
        print $ch qq{int main(void) { return 0; }\n};
        close($ch);
        my $exefile = File::Temp::mktemp( 'assertlibXXXXXXXX' ) . $Config{_exe};
        my @sys_cmd;
        # FIXME: re-factor - almost identical code later when linking
        if ( $Config{cc} eq 'cl' ) {                 # Microsoft compiler
            require Win32;
            @sys_cmd = (
                @$cc,
                $cfile,
                "/Fe$exefile",
                (map { '/I'.Win32::GetShortPathName($_) } @incpaths),
		"/link",
		@$ld,
		split(' ', $Config{libs}),
            );
        } elsif($Config{cc} =~ /bcc32(\.exe)?/) {    # Borland
            @sys_cmd = (
                @$cc,
                @$ld,
                (map { "-I$_" } @incpaths),
                "-o$exefile",
                $cfile
            );
        } else { # Unix-ish: gcc, Sun, AIX (gcc, cc), ...
            @sys_cmd = (
                @$cc,
                @$ld,
                $cfile,
                (map { "-I$_" } @incpaths),
                "-o", "$exefile"
            );
        }
        warn "# @sys_cmd\n" if $args{debug};
        my $rv = $args{debug} ? system(@sys_cmd) : _quiet_system(@sys_cmd);
        push @missing, $header if $rv != 0 || ! -x $exefile;
        _cleanup_exe($exefile);
        unlink $cfile;
    }

    # now do each library in turn with headers
    my($ch, $cfile) = File::Temp::tempfile(
        'assertlibXXXXXXXX', SUFFIX => '.c'
    );
    my $ofile = $cfile;
    $ofile =~ s/\.c$/$Config{_o}/;
    print $ch qq{#include <$_>\n} foreach (@headers);
    print $ch "int main(int argc, char *argv[]) { ".($args{function} || 'return 0;')." }\n";
    close($ch);
    for my $lib ( @libs ) {
        my $exefile = File::Temp::mktemp( 'assertlibXXXXXXXX' ) . $Config{_exe};
        my @sys_cmd;
        if ( $Config{cc} eq 'cl' ) {                 # Microsoft compiler
            require Win32;
            my @libpath = map { 
                q{/libpath:} . Win32::GetShortPathName($_)
            } @libpaths; 
            # this is horribly sensitive to the order of arguments
            @sys_cmd = (
                @$cc,
                $cfile,
                "${lib}.lib",
                "/Fe$exefile", 
                (map { '/I'.Win32::GetShortPathName($_) } @incpaths),
                "/link",
                @$ld,
                split(' ', $Config{libs}),
                (map {'/libpath:'.Win32::GetShortPathName($_)} @libpaths),
            );
        } elsif($Config{cc} eq 'CC/DECC') {          # VMS
        } elsif($Config{cc} =~ /bcc32(\.exe)?/) {    # Borland
            @sys_cmd = (
                @$cc,
                @$ld,
                "-o$exefile",
                (map { "-I$_" } @incpaths),
                (map { "-L$_" } @libpaths),
                "-l$lib",
                $cfile);
        } else {                                     # Unix-ish
                                                     # gcc, Sun, AIX (gcc, cc)
            @sys_cmd = (
                @$cc,
                @$ld,
                $cfile,
                "-o", "$exefile",
                (map { "-I$_" } @incpaths),
                (map { "-L$_" } @libpaths),
                "-l$lib",
            );
        }
        warn "# @sys_cmd\n" if $args{debug};
        local $ENV{LD_RUN_PATH} = join(":", @libpaths).":".$ENV{LD_RUN_PATH} unless $^O eq 'MSWin32';
        local $ENV{PATH} = join(";", @libpaths).";".$ENV{PATH} if $^O eq 'MSWin32';
        my $rv = $args{debug} ? system(@sys_cmd) : _quiet_system(@sys_cmd);
        if ($rv != 0 || ! -x $exefile) {
            push @missing, $lib;
        }
        else {
            my $absexefile = File::Spec->rel2abs($exefile);
            $absexefile = '"'.$absexefile.'"' if $absexefile =~ m/\s/;
            if (system($absexefile) != 0) {
                push @wrongresult, $lib;
            }
            else {
                if ($analyze_binary) {
                    push @wronganalysis, $lib if !$analyze_binary->($lib, $exefile)
                }
            }
        }
        _cleanup_exe($exefile);
    } 
    unlink $cfile;

    my $miss_string = join( q{, }, map { qq{'$_'} } @missing );
    die("Can't link/include C library $miss_string, aborting.\n") if @missing;
    my $wrong_string = join( q{, }, map { qq{'$_'} } @wrongresult);
    die("wrong result: $wrong_string\n") if @wrongresult;
    my $analysis_string = join(q{, }, map { qq{'$_'} } @wronganalysis );
    die("wrong analysis: $analysis_string") if @wronganalysis;
}

sub _cleanup_exe {
    my ($exefile) = @_;
    my $ofile = $exefile;
    $ofile =~ s/$Config{_exe}$/$Config{_o}/;
    # List of files to remove
    my @rmfiles;
    push @rmfiles, $exefile, $ofile, "$exefile\.manifest";
    if ( $Config{cc} eq 'cl' ) {
        # MSVC also creates foo.ilk and foo.pdb
        my $ilkfile = $exefile;
        $ilkfile =~ s/$Config{_exe}$/.ilk/;
        my $pdbfile = $exefile;
        $pdbfile =~ s/$Config{_exe}$/.pdb/;
	push @rmfiles, $ilkfile, $pdbfile;
    }
    foreach (@rmfiles) {
	if ( -f $_ ) {
	    unlink $_ or warn "Could not remove $_: $!";
	}
    }
    return
}
    
# return ($cc, $ld)
# where $cc is an array ref of compiler name, compiler flags
# where $ld is an array ref of linker flags
sub _findcc {
    my ($debug, $user_ccflags, $user_ldflags) = @_;
    # Need to use $keep=1 to work with MSWin32 backslashes and quotes
    my $Config_ccflags =  $Config{ccflags};  # use copy so ASPerl will compile
    my @Config_ldflags = ();
    for my $config_val ( @Config{qw(ldflags)} ){
        push @Config_ldflags, $config_val if ( $config_val =~ /\S/ );
    }
    my @ccflags = grep { length } quotewords('\s+', 1, $Config_ccflags||'', $user_ccflags||'');
    my @ldflags = grep { length } quotewords('\s+', 1, @Config_ldflags, $user_ldflags||'');
    my @paths = split(/$Config{path_sep}/, $ENV{PATH});
    my @cc = split(/\s+/, $Config{cc});
    if (check_compiler ($cc[0], $debug)) {
	return ( [ @cc, @ccflags ], \@ldflags );
    }
    # Find the extension for executables.
    my $exe = $Config{_exe};
    if ($^O eq 'cygwin') {
	$exe = '';
    }
    foreach my $path (@paths) {
	# Look for "$path/$cc[0].exe"
        my $compiler = File::Spec->catfile($path, $cc[0]) . $exe;
	if (check_compiler ($compiler, $debug)) {
	    return ([ $compiler, @cc[1 .. $#cc], @ccflags ], \@ldflags)
	}
        next if ! $exe;
	# Look for "$path/$cc[0]" without the .exe, if necessary.
        $compiler = File::Spec->catfile($path, $cc[0]);
	if (check_compiler ($compiler, $debug)) {
	    return ([ $compiler, @cc[1 .. $#cc], @ccflags ], \@ldflags)
	}
    }
    die("Couldn't find your C compiler.\n");
}

sub check_compiler
{
    my ($compiler, $debug) = @_;
    if (-f $compiler && -x $compiler) {
	if ($debug) {
	    warn("# Compiler seems to be $compiler\n");
	}
	return 1;
    }
    return '';
}


# code substantially borrowed from IPC::Run3
sub _quiet_system {
    my (@cmd) = @_;

    # save handles
    local *STDOUT_SAVE;
    local *STDERR_SAVE;
    open STDOUT_SAVE, ">&STDOUT" or die "CheckLib: $! saving STDOUT";
    open STDERR_SAVE, ">&STDERR" or die "CheckLib: $! saving STDERR";
    
    # redirect to nowhere
    local *DEV_NULL;
    open DEV_NULL, ">" . File::Spec->devnull 
        or die "CheckLib: $! opening handle to null device";
    open STDOUT, ">&" . fileno DEV_NULL
        or die "CheckLib: $! redirecting STDOUT to null handle";
    open STDERR, ">&" . fileno DEV_NULL
        or die "CheckLib: $! redirecting STDERR to null handle";

    # run system command
    my $rv = system(@cmd);

    # restore handles
    open STDOUT, ">&" . fileno STDOUT_SAVE
        or die "CheckLib: $! restoring STDOUT handle";
    open STDERR, ">&" . fileno STDERR_SAVE
        or die "CheckLib: $! restoring STDERR handle";

    return $rv;
}

=head1 PLATFORMS SUPPORTED

You must have a C compiler installed.  We check for C<$Config{cc}>,
both literally as it is in Config.pm and also in the $PATH.

It has been tested with varying degrees of rigorousness on:

=over

=item gcc (on Linux, *BSD, Mac OS X, Solaris, Cygwin)

=item Sun's compiler tools on Solaris

=item IBM's tools on AIX

=item SGI's tools on Irix 6.5

=item Microsoft's tools on Windows

=item MinGW on Windows (with Strawberry Perl)

=item Borland's tools on Windows

=item QNX

=back

=head1 WARNINGS, BUGS and FEEDBACK

This is a very early release intended primarily for feedback from
people who have discussed it.  The interface may change and it has
not been adequately tested.

Feedback is most welcome, including constructive criticism.
Bug reports should be made using L<http://rt.cpan.org/> or by email.

When submitting a bug report, please include the output from running:

    perl -V
    perl -MDevel::CheckLib -e0

=head1 SEE ALSO

L<Devel::CheckOS>

L<Probe::Perl>

=head1 AUTHORS

David Cantrell E<lt>david@cantrell.org.ukE<gt>

David Golden E<lt>dagolden@cpan.orgE<gt>

Yasuhiro Matsumoto E<lt>mattn@cpan.orgE<gt>

Thanks to the cpan-testers-discuss mailing list for prompting us to write it
in the first place;

to Chris Williams for help with Borland support;

to Tony Cook for help with Microsoft compiler command-line options

=head1 COPYRIGHT and LICENCE

Copyright 2007 David Cantrell. Portions copyright 2007 David Golden.

This module is free-as-in-speech software, and may be used, distributed,
and modified under the same conditions as perl itself.

=head1 CONSPIRACY

This module is also free-as-in-mason software.

=cut

1;

 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 strict;
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;



=pod

=encoding utf-8

=head1 NAME

AAAA::Mail::SpamAssassin - making Mail::SpamAssassin installable

=head1 SYNOPSIS

  # in Makefile.PL

  requires 'AAAA::Mail::SpamAssassin';

=head1 DESCRIPTION

For some reason dependency resolution via the CPAN toolchains does not
work very well for L<Mail::SpamAssassin>. To install it without manual
work you need dependencies installed beforehand.

C<AAAA::Mail::SpamAssassin> is a L<Task>-style distribution that makes
sure that dependencies are installed so that L<Mail::SpamAssassin>
installation does not complain.

If you have a dependency on L<Mail::SpamAssassin> add
C<AAAA::Mail::SpamAssassin> as an additional dependency and (only) the
most crucial dependencies will be installed before
L<Mail::SpamAssassin>.

Why the C<'AAAA'>? L<CPAN> and L<CPANPLUS> install prereqs sorted
alphabetically, the C<'AAAA'> ensures that this prereq is installed
before L<Mail::SpamAssassin>. Simples.

=head1 Acknowledgements

Idea shamelessly stolen from Chris C<BinGOs> Williams'
L<AAAA::Crypt::DH|AAAA::Crypt::DH>.

=head1 SEE ALSO

L<Mail::SpamAssassin>

L<AAAA::Crypt::DH>

=head1 AUTHOR

Steffen Schwigon <ss5@renormalist.net>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2012 by Steffen Schwigon.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut


__END__

 view all matches for this distribution


AAAAAAAAA

 view release on metacpan or  search on metacpan

aaa/AAAAAAAAA.pm  view on Meta::CPAN

package AAAAAAAAA;

use strict;
use warnings;

our $VERSION = '1.01';

my @aaaaaaa = ('a'..'z', 'A'..'Z', 0..9);
my %aaaaaaaa_aa_aaaa;
for my $a (0..$#aaaaaaa) {
    my $aaaa = sprintf("%06b", $a);
    $aaaa =~ s{0}{a}g;
    $aaaa =~ s{1}{A}g;
    $aaaaaaaa_aa_aaaa{ $aaaaaaa[$a] } = $aaaa;
}

my %aaaa_aa_aaaaaaaa;
@aaaa_aa_aaaaaaaa{values %aaaaaaaa_aa_aaaa} = keys %aaaaaaaa_aa_aaaa;

sub aaaa {
    open my $aa, "<", $0 or die "Aaa'a aaaa aaa aaaaaa aaaa aaa aaaaaaaaaaa: $!";

    my $aaaa = join "", <$aa>;
    $aaaa =~ s{use\s+AAAAAAAAA\b}{}x;

    # Aaa aaa aaaaaaa
    if( $aaaa =~ /[b-zB-Z0-9]/ ) {
        my $aaaaaaaa_aaaa = $aaaa;
        aaaaaa(\$aaaa);
        eval $aaaaaaaa_aaaa;
    }
    else {
        aaaaaaaa(\$aaaa);
        eval $aaaa;
    }

    exit;
}

sub aaaaaa {
    my $aaaa = shift;

    $$aaaa =~ s{([a-zA-Z0-9])}{$aaaaaaaa_aa_aaaa{$1}}gx;

    open my $aa, ">", $0 or die "Aaa'a aaaa aaa aaaaaa aaaa aaa aaaaaaaaaaa: $!";
    print $aa "use AAAAAAAAA";
    print $aa $$aaaa;

    return;
}


sub aaaaaaaa {
    my $aaaa = shift;

    $$aaaa =~ s{ ([Aa]{6}) }{$aaaa_aa_aaaaaaaa{$1}}gx;

    return;
}


aaaa();


=head1 AAAA

AAAAAAAAA - Aaaaaa aaaaa aa aaaaaa Aaaaa aaaa

=head1 AAAAAAAA

    use AAAAAAAAA;

=head1 AAAAAAAAAAA

AAAAAAA AA AAA AAAAAAAAA AAAAA AA AAAAAA AAAAAA, AAAAAAA AA AAAAAA
AAAAAA, AAAAA AAAAAAA AAA! AA AAA AAAA AAAA AAAAAAAA AAAA AA AAAAAA
AAAAA

    AAAA AAAA AAAAAA AA AAA!
    AAA AAAA AAAA AAA!
    AAAAAAA AAAAA AAA!
    AAAAA AAAA AAA!
    AAAA AAAAA AAA!
    AAA AAAAAA "A" AAAA AAA! 

AAAAA AAA AAA, AAAAAAA AAA AAAA, AA AAAAAA AAAAAA, AAAA AAAAA AAA!


AAAA, AA AAAAAA AAAAAA, AAAA AAAA(A) AAA!
AA AAA AAAA AA AAAAA AAAAAAA AAAAAAA?

AAAAAAA AA AAAAAA AAAAAA , AAAAAA AAAAA AA AAAAA AAAA AAA!

AAAAAA, AA AAAAA AAAAAAAAA AAAAAAA, AAA AAAAAAA AAAAAAAA. (AA AAAAAA
AAAAAA-AA, AAAAA AAAA.) AAAA, AA AAAA AAAAA'A AA AAA AAAAA, AAAA AAAA
AA AAA AAA AAAAAAA, AAAAAAAAAAAA AAA AAAAA (AA AAAAAAA AA AA, AA, AA
AAA), AA AAAAA AAAAAA AAAA AAA AA AAA AAA. AA AAAA AA AAA AAA AAAAA
AAAAAA AAAAAAA.  AAAAA AAAAA

AAAAA AAAAA AAA AA AAAAAAA AAAA AAAAAA AAAAAA AAAAAAA

=cut


'A reckless disregard for taste';

 view all matches for this distribution


AAC-Pvoice

 view release on metacpan or  search on metacpan

lib/AAC/Pvoice.pm  view on Meta::CPAN

package AAC::Pvoice;

use strict;
use warnings;

use Wx qw(:everything);
use Wx::Perl::Carp;
use AAC::Pvoice::Bitmap;
use AAC::Pvoice::Input;
use AAC::Pvoice::Row;
use AAC::Pvoice::EditableRow;
use AAC::Pvoice::Panel;
use AAC::Pvoice::Dialog;
use Text::Wrap qw(wrap);

BEGIN {
	use Exporter ();
	use vars qw ($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
	$VERSION     = 0.91;
	@ISA         = qw (Exporter);
	@EXPORT      = qw (MessageBox);
	@EXPORT_OK   = qw ();
	%EXPORT_TAGS = ();
}

sub MessageBox
{
	my ($message, $caption, $style, $parent, $x, $y) = @_;
    $caption ||= 'Message';
	$style   ||= wxOK;
	$x       ||= -1;
	$y       ||= -1;

	$Text::Wrap::columns = 25;
	$message = wrap('','',$message)."\n";
	
    my $width = 0;
    $width = 25 if $style & wxOK;
    $width = 30 if $style & wxYES_NO;
    $width = 60 if $style & wxCANCEL;

	my $p = Wx::Frame->new(undef, -1, 'tmp');
	my $m = Wx::StaticText->new($p, -1, $message, wxDefaultPosition, wxDefaultSize, wxALIGN_CENTRE);
	$m->SetFont(Wx::Font->new(  10,                 # font size
                                wxDECORATIVE,       # font family
                                wxNORMAL,           # style
                                wxNORMAL,           # weight
                                0,                  
                                'Comic Sans MS',    # face name
                                wxFONTENCODING_SYSTEM));

	my $h = $m->GetSize->GetHeight;
	$p->Destroy;

	my $d = AAC::Pvoice::Dialog->new(undef, -1, $caption, [$x,$y], [310,100+$h]);
	
	my $messagectrl = Wx::StaticText->new($d->{panel},
                                          -1,
                                          $message,
                                          wxDefaultPosition,
                                          wxDefaultSize,
                                          wxALIGN_CENTRE);
	$messagectrl->SetBackgroundColour($d->{backgroundcolour});
	$messagectrl->SetFont(Wx::Font->new(10,                 # font size
                                        wxDECORATIVE,       # font family
                                        wxNORMAL,           # style
                                        wxNORMAL,           # weight
                                        0,                  
                                        'Comic Sans MS',    # face name
                                        wxFONTENCODING_SYSTEM));

	$d->Append($messagectrl,1);
    my $ok     = [Wx::NewId,AAC::Pvoice::Bitmap->new('',50,25,'OK',    Wx::Colour->new(255, 230, 230)),sub{$d->SetReturnCode(wxOK);    $d->Close()}];
    my $yes    = [Wx::NewId,AAC::Pvoice::Bitmap->new('',50,30,'Yes',   Wx::Colour->new(255, 230, 230)),sub{$d->SetReturnCode(wxYES);   $d->Close()}];
    my $no     = [Wx::NewId,AAC::Pvoice::Bitmap->new('',50,25,'No',    Wx::Colour->new(255, 230, 230)),sub{$d->SetReturnCode(wxNO);    $d->Close()}];
    my $cancel = [Wx::NewId,AAC::Pvoice::Bitmap->new('',50,60,'Cancel',Wx::Colour->new(255, 230, 230)),sub{$d->SetReturnCode(wxCANCEL);$d->Close()}];
    my $items = [];
    push @$items, $ok     if $style & wxOK;
    push @$items, $yes    if $style & wxYES_NO;
    push @$items, $no     if $style & wxYES_NO;
    push @$items, $cancel if $style & wxCANCEL;
	$d->Append(AAC::Pvoice::Row->new($d->{panel},          # parent
                                     scalar(@$items),      # max
                                     $items,               # items
                                     wxDefaultPosition,    # pos
                                     wxDefaultSize,
                                     $width,
                                     25,
                                     $d->{ITEMSPACING},
                                     $d->{backgroundcolour}),
                0); #selectable
	return $d->ShowModal();
}

=pod

=head1 NAME

AAC::Pvoice - Create GUI software for disabled people

=head1 SYNOPSIS

  use AAC::Pvoice
  # this includes all AAC::Pvoice modules


=head1 DESCRIPTION

AAC::Pvoice is a set of modules to create software for people who can't
use a normal mouse and/or keyboard. To see an application that uses this
set of modules, take a look at pVoice (http://www.pvoice.org, or the
sources on http://opensource.pvoice.org). 

AAC::Pvoice is in fact a wrapper around many wxPerl classes, to make it
easier to create applications like pVoice.


=head1 USAGE

=head2 AAC::Pvoice::MessageBox(message, caption, style, parent, x, y)

This function is similar to Wx::MessageBox. It uses the same parameters as
Wx::MessageBox does. Currently the style parameter doesn't support the
icons that can be set on Wx::MessageBox.

See the individual module's documentation

=head1 BUGS

probably a lot, patches welcome!


=head1 AUTHOR

	Jouke Visser
	jouke@pvoice.org
	http://jouke.pvoice.org

=head1 COPYRIGHT

This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.

The full text of the license can be found in the
LICENSE file included with this module.


=head1 SEE ALSO

perl(1), Wx, AAC::Pvoice::Panel, AAC::Pvoice::Bitmap, AAC::Pvoice::Row
AAC::Pvoice::EditableRow, AAC::Pvoice::Input

=cut


1; 
__END__

 view all matches for this distribution


ABI

 view release on metacpan or  search on metacpan

ABI.pm  view on Meta::CPAN

#$Id: ABI.pm,v 1.3.2.4 2006/11/20 03:18:12 malay Exp $
# Perl module to parse ABI chromatogram file
# Malay <malay@bioinformatics.org>
# Copyright (c) 2002, 2003, 2004, 2005, 2006 Malay Kumar Basu
# You may distribute this module under the same terms as perl itself
# Thanks to David H. Klatte for all the hard work!
package ABI;
use IO::File;
use Carp;
use strict;

=head1 NAME

ABI.pm - Perl module to parse chromatogram files generated by
Applied Biosystems (ABI) automated DNA sequencing machine.

Please cite:
ABI.pm - Perl module to parse chromatogram files generated by
Applied Biosystems (ABI) automated DNA sequencing machine.
by Malay K Basu (malay@bioinformatics.org); source code available at:
http://search.cpan.org/~malay

=head1 VERSION

Version 1.0

=cut

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
module only gives access to the most used information stored in
ABI file. All the accesses are read only.

If you have edited the file using a trace editor, then you can use the corresponding 
method to access the edited sequence and base calls.



=head1 CONSTRUCTOR

=head2 new()

  Usage : $abi = ABI->new(-file=>"filename");
          $abi = ABI->new("filename"); # same thing

=cut

sub new {
	my $class = shift;
	my $self  = {};
	bless $self, ref($class) || $class;
	$self->_init(@_);

	#print "****", $self->{_mac_header}, "\n";
	return $self;
}

sub _init {
	my ( $self, @args ) = @_;
	my ($file) = $self->_rearrange( ["FILE"], @args );
	if ( !defined($file) ) {
		croak "Can't open the input file\n";
	} else {
		$self->set_file_handle($file);
	}
	$self->{_sequence}             = "";
	$self->{_sequence_corrected}   = "";
	$self->{_sample}               = "";
	$self->{A}                     = [];
	$self->{T}                     = [];
	$self->{G}                     = [];
	$self->{C}                     = [];
	$self->{_basecalls}            = [];
	$self->{_basecalls_corrected}  = [];
	$self->{_trace_length}         = 0;
	$self->{_seq_length}           = 0;
	$self->{_seq_length_corrected} = 0;
	$self->{_abs_index}            = 26;
	$self->{_index}                = undef;
	$self->{PLOC1}                 = undef;
	$self->{PLOC}                  = undef;
	$self->{_a_start}              = undef;
	$self->{_g_start}              = undef;
	$self->{_c_start}              = undef;
	$self->{_t_start}              = undef;
	$self->{DATA9}                 = undef;
	$self->{DATA10}                = undef;
	$self->{DATA11}                = undef;
	$self->{DATA12}                = undef;
	$self->{PBAS1}                 = undef;
	$self->{PBAS2}                 = undef;
	$self->{FWO}                   = undef;
	$self->{_mac_header}           = 0;
	$self->{_maximum_trace}        = 0;

	if ( $self->_is_abi() ) {

		#print "ABI FILE\n";
		$self->_set_index();
		$self->_set_base_calls();
		$self->_set_corrected_base_calls();
		$self->_set_seq();
		$self->_set_corrected_seq();
		$self->_set_traces();
		$self->_set_max_trace();
		$self->_set_sample_name();
		close( $self->{_fh} );
	}
	return $self;
}

sub set_file_handle {
	my $self = shift;
	my $path = shift;
	my $fh   = IO::File->new();
	if ( $fh->open("< $path") ) {
		binmode($fh);
		$self->{_fh} = $fh;
	} else {
		croak "Could not open $path in ABITrace::set_file_handle\n";
	}
}

sub _rearrange {
	my ( $self, $order, @param ) = @_;
	return unless @param;
	return @param unless ( defined( $param[0] ) && $param[0] =~ /^-/ );
	for ( my $i = 0 ; $i < @param ; $i += 2 ) {
		$param[$i] =~ s/^\-//;
		$param[$i] =~ tr/a-z/A-Z/;
	}

	# Now we'll convert the @params variable into an associative array.
	local ($^W) = 0;    # prevent "odd number of elements" warning with -w.
	my (%param) = @param;
	my (@return_array);

	# What we intend to do is loop through the @{$order} variable,
	# and for each value, we use that as a key into our associative
	# array, pushing the value at that key onto our return array.
	my ($key);
	foreach $key ( @{$order} ) {
		my ($value) = $param{$key};
		delete $param{$key};
		push( @return_array, $value );
	}

#    print "\n_rearrange() after processing:\n";
#    my $i; for ($i=0;$i<@return_array;$i++) { printf "%20s => %s\n", ${$order}[$i], $return_array[$i]; } <STDIN>;
	return (@return_array);
}

sub _is_abi {
	my $self = shift;
	my $fh   = $self->{"_fh"};
	my $buf;
	seek( $fh, 0, 0 );
	read( $fh, $buf, 3 );

	#my $a = unpack("n*", $buf);
	if ( $buf eq "ABI" ) {
		return 1;
	} else {
		seek( $fh, 128, 0 );
		read( $fh, $buf, 3 );
		if ( $buf eq "ABI" ) {
			$self->_set_mac_header();
			return 1;
		} else {
			return 0;
		}
	}
}

sub _set_mac_header {
	my $self = shift;
	$self->{_mac_header} = 128;
}

sub _set_index {
	my $self         = shift;
	my $data_counter = 0;
	my $pbas_counter = 0;
	my $ploc_counter = 0;
	my ( $num_records, $buf );

	#print $self->{_fh}, "\n";
	#print $self->{_mac_header}, "\n";
	seek( $self->{_fh}, $self->{_abs_index} + $self->{_mac_header}, 0 );
	read( $self->{_fh}, $buf, 4 );
	$self->{_index} = unpack( "N", $buf );

	#print $self->{_index};
	seek( $self->{_fh}, $self->{_abs_index} - 8 + $self->{_mac_header}, 0 );
	read( $self->{_fh}, $buf, 4 );
	$num_records = unpack( "N", $buf );
	for ( my $i = 0 ; $i <= $num_records - 1 ; $i++ ) {
		seek( $self->{_fh}, $self->{_index} + ( $i * 28 ), 0 );
		read( $self->{_fh}, $buf, 4 );
		if ( $buf eq "FWO_" ) {
			$self->{FWO} = $self->{_index} + ( $i * 28 ) + 20;
		}
		if ( $buf eq "DATA" ) {
			$data_counter++;
			if ( $data_counter == 9 ) {
				$self->{DATA9} = $self->{_index} + ( $i * 28 ) + 20;
			}
			if ( $data_counter == 10 ) {
				$self->{DATA10} = $self->{_index} + ( $i * 28 ) + 20;
			}
			if ( $data_counter == 11 ) {
				$self->{DATA11} = $self->{_index} + ( $i * 28 ) + 20;
			}
			if ( $data_counter == 12 ) {
				$self->{DATA12} = $self->{_index} + ( $i * 28 ) + 20;
			}
		}
		if ( $buf eq "PBAS" ) {
			$pbas_counter++;
			if ( $pbas_counter == 1 ) {
				$self->{PBAS1} = $self->{_index} + ( $i * 28 ) + 20;
			}
			if ( $pbas_counter == 2 ) {
				$self->{PBAS2} = $self->{_index} + ( $i * 28 ) + 20;
			}
		}
		if ( $buf eq "PLOC" ) {
			$ploc_counter++;
			if ( $ploc_counter == 1 ) {
				$self->{PLOC1} = $self->{_index} + ( $i * 28 ) + 20;
			}
			if ( $ploc_counter == 2 ) {
				$self->{PLOC} = $self->{_index} + ( $i * 28 ) + 20;
			}
		}
		if ( $buf eq "SMPL" ) {
			$self->{SMPL} = $self->{_index} + ( $i * 28 ) + 20;
		}
	}
	seek( $self->{_fh}, $self->{DATA12} - 8, 0 );
	read( $self->{_fh}, $buf, 4 );
	$self->{_trace_length} = unpack( "N", $buf );
	seek( $self->{_fh}, $self->{PBAS2} - 4, 0 );
	read( $self->{_fh}, $buf, 4 );
	$self->{_seq_length} = unpack( "N", $buf );
	seek( $self->{_fh}, $self->{PBAS1} - 4, 0 );
	read( $self->{_fh}, $buf, 4 );
	$self->{_seq_length_corrected} = unpack( "N", $buf );
	$self->{PLOC}   = $self->_get_int( $self->{PLOC} ) + $self->{_mac_header};
	$self->{PLOC1}  = $self->_get_int( $self->{PLOC1} ) + $self->{_mac_header};
	$self->{DATA9}  = $self->_get_int( $self->{DATA9} ) + $self->{_mac_header};
	$self->{DATA10} = $self->_get_int( $self->{DATA10} ) + $self->{_mac_header};
	$self->{DATA11} = $self->_get_int( $self->{DATA11} ) + $self->{_mac_header};
	$self->{DATA12} = $self->_get_int( $self->{DATA12} ) + $self->{_mac_header};
	$self->{PBAS1}  = $self->_get_int( $self->{PBAS1} ) + $self->{_mac_header};
	$self->{PBAS2}  = $self->_get_int( $self->{PBAS2} ) + $self->{_mac_header};
	$self->{SMPL} += $self->{_mac_header};
}

sub _set_base_calls {
	my $self = shift;
	my $buf;
	my $length = $self->{_seq_length} * 2;
	my $fh     = $self->{_fh};
	seek( $fh, $self->{PLOC}, 0 );
	read( $fh, $buf, $length );
	@{ $self->{_basecalls} } = unpack( "n" x $length, $buf );

	# print "@{$self->{_basecalls}}" , "\n";
}

sub _set_corrected_base_calls {
	my $self = shift;
	my $buf;
	my $length = $self->{_seq_length_corrected} * 2;
	my $fh     = $self->{_fh};
	seek( $fh, $self->{PLOC1}, 0 );
	read( $fh, $buf, $length );
	@{ $self->{_basecalls_corrected} } = unpack( "n" x $length, $buf );
}

sub _set_seq {
	my $self = shift;
	my $buf;
	my $length = $self->{_seq_length};
	my $fh     = $self->{_fh};
	seek( $fh, $self->{PBAS2}, 0 );
	read( $fh, $buf, $length );
	$self->{_sequence} = $buf;

	#my @seq = unpack( "C" x $length, $buf);
	#print $buf, "\n";
}

sub _set_corrected_seq {
	my $self = shift;
	my $buf;
	my $length = $self->{_seq_length_corrected};
	my $fh     = $self->{_fh};
	seek( $fh, $self->{PBAS1}, 0 );
	read( $fh, $buf, $length );
	$self->{_sequence_corrected} = $buf;
}

sub _set_traces {
	my $self = shift;
	my $buf;
	my ( @pointers, @A, @G, @C, @T );
	my (@datas) =
	  ( $self->{DATA9}, $self->{DATA10}, $self->{DATA11}, $self->{DATA12} );
	my $fh = $self->{_fh};
	seek( $fh, $self->{FWO}, 0 );
	read( $fh, $buf, 4 );
	my @order = split( //, $buf );

	#print "@order", "\n";
	for ( my $i = 0 ; $i < 4 ; $i++ ) {
		if ( $order[$i] =~ /A/i ) {
			$pointers[0] = $datas[$i];
		} elsif ( $order[$i] =~ /C/i ) {
			$pointers[1] = $datas[$i];
		} elsif ( $order[$i] =~ /G/i ) {
			$pointers[2] = $datas[$i];
		} elsif ( $order[$i] =~ /T/i ) {
			$pointers[3] = $datas[$i];
		} else {
			croak "Wrong traces\n";
		}
	}
	for ( my $i = 0 ; $i < 4 ; $i++ ) {
		seek( $fh, $pointers[$i], 0 );
		read( $fh, $buf, $self->{_trace_length} * 2 );
		if ( $i == 0 ) {
			@A = unpack( "n" x $self->{_trace_length}, $buf );
		}
		if ( $i == 1 ) {
			@C = unpack( "n" x $self->{_trace_length}, $buf );
		}
		if ( $i == 2 ) {
			@G = unpack( "n" x $self->{_trace_length}, $buf );
		}
		if ( $i == 3 ) {
			@T = unpack( "n" x $self->{_trace_length}, $buf );
		}
	}
	@{ $self->{A} } = @A;
	@{ $self->{G} } = @G;
	@{ $self->{T} } = @T;
	@{ $self->{C} } = @C;
}

sub _get_int {
	my $self = shift;
	my $buf;
	my $pos = shift;
	my $fh  = $self->{_fh};
	seek( $fh, $pos, 0 );
	read( $fh, $buf, 4 );
	return unpack( "N", $buf );
}

sub _set_max_trace {
	my $self = shift;
	my @A    = @{ $self->{A} };
	my @T    = @{ $self->{T} };
	my @G    = @{ $self->{G} };
	my @C    = @{ $self->{C} };
	my $max  = 0;
	for ( my $i = 0 ; $i < @T ; $i++ ) {
		if ( $T[$i] > $max ) { $max = $T[$i]; }
		if ( $A[$i] > $max ) { $max = $A[$i]; }
		if ( $G[$i] > $max ) { $max = $G[$i]; }
		if ( $C[$i] > $max ) { $max = $C[$i]; }
	}
	$self->{_maximum_trace} = $max;
}

sub _set_sample_name {
	my $self = shift;
	my $buf;
	my $fh = $self->{_fh};
	seek( $fh, $self->{SMPL}, 0 );
	read( $fh, $buf, 1 );
	my $length = unpack( "C", $buf );
	read( $fh, $buf, $length );
	$self->{_sample} = $buf;
}

=head1 METHODS

=head2 get_max_trace()

  Title    :  get_max_trace()
  Usage    :  $max = $abi->get_max_trace();
  Function :  Returns the maximum trace value of all the traces.
  Args     :  Nothing
  Returns  :  A scalar

=cut

sub get_max_trace {
	my $self = shift;
	return $self->{_maximum_trace};
}

=head2 get_trace()

  Title    :  get_trace()
  Usage    :  my @a = $abi->get_trace("A");
  Function :  Returns the raw traces as array.
  Args     :  "A" or "G" or "C" or "T"
  Returns  :  An array

=cut

sub get_trace {
	my $self   = shift;
	my $symbol = shift;
	if ( $symbol =~ /A/i ) {
		return @{ $self->{A} };
	} elsif ( $symbol =~ /G/i ) {
		return @{ $self->{G} };
	} elsif ( $symbol =~ /C/i ) {
		return @{ $self->{C} };
	} elsif ( $symbol =~ /T/i ) {
		return @{ $self->{T} };
	} else {
		croak "Illegal symbol\n";
	}
}

=head2 get_sequence()

  Title    : get_sequence()
  Usage    : my $seq = $abi->get_sequence();
  Function : Returns the original unedited sequence as string. If you want to access the edited
             sequence use "get_corrected_sequence()" instead.
  Args     : Nothing
  Returns  : A scalar

=cut

sub get_sequence {
	my $self = shift;
	return $self->{_sequence};
}

=head2 get_corrected_sequence()

  Title    : get_corrected_sequence()
  Usage    : my $seq = $abi->get_corrected_sequence();
  Function : Returns the corrected sequence as string. If you want to access the original 
             unedited sequence, use "get_sequence()" instead.
  Args     : Nothing
  Returns  : A scalar

=cut

sub get_corrected_sequence {
	my $self = shift;
	return $self->{_sequence_corrected};
}

=head2 get_sequence_length()

  Title    : get_sequence_length()
  Usage    : my $seq_length = $abi->get_sequence_length();
  Function : Returns the sequence length of the orginal unedited sequence.
  Args     : Nothing
  Returns  : A scalar

=cut

sub get_sequence_length {
	my $self = shift;
	return $self->{_seq_length};
}

=head2 get_corrected_sequence_length()

  Title    : get_corrected_sequence_length()
  Usage    : my $seq_length = $abi->get_corrected_sequence_length();
  Function : Returns the length of the edited sequence. 
  Args     : Nothing
  Returns  : A scalar

=cut

sub get_corrected_sequence_length {
	my $self = shift;

	#print STDERR "**ABI**",$self->{_seq_length_corrected},"\n";
	return $self->{_seq_length_corrected};
}

=head2 get_trace_length()

  Title    : get_trace_length()
  Usage    : my $trace_length = $abi->get_trace_length();
  Function : Returns the trace length
  Args     : Nothing
  Returns  : A scalar

=cut

sub get_trace_length {
	my $self = shift;
	return $self->{_trace_length};
}

=head2 get_base_calls()

  Title    : get_base_calls()
  Usage    : my @base_calls = $abi->get_base_calls();
  Function : Returns the called bases by the base caller. This method will return the unedited 
  	         original basecalls created by the basecaller.
  Args     : Nothing
  Returns  : An array

=cut

sub get_base_calls {
	my $self = shift;
	return @{ $self->{_basecalls} };
}

=head2 get_corrected_base_calls()

  Title    : get_corrected_base_calls()
  Usage    : my @base_calls = $abi->get_corrected_base_calls();
  Function : If you have edited the trace file you can get the corrected base call 
             with this method
  Args     : Nothing
  Returns  : An array

=cut

sub get_corrected_base_calls {
	my $self = shift;
	return @{ $self->{_basecalls_corrected} };
}

=head2 get_sample_name()

  Title    : get_sample_name()
  Usage    : my $sample = $abi->get_sample_name();
  Function : Returns hard coded sample name
  Args     : Nothing
  Returns  : A scalar

=cut

sub get_sample_name {
	my $self = shift;
	return $self->{_sample};
}

=head1 AUTHOR

Malay <malay@bioinformatics.org>

=head1 BUGS

Please report any bugs or feature requests to
C<bug-abi at rt.cpan.org>, or through the web interface at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=ABI>.
I will be notified, and then you'll automatically be notified of progress on
your bug as I make changes.

or 

You can directly contact me to my email address.


=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc ABI

You can also look for information at:

=over 4

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/ABI>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/ABI>

=item * RT: CPAN's request tracker

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=ABI>

=item * Search CPAN

L<http://search.cpan.org/dist/ABI>

=back


=head1 COPYRIGHT & LICENSE

Copyright 2002,2006 Malay, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1;

 view all matches for this distribution


ABNF-Grammar

 view release on metacpan or  search on metacpan

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

package ABNF::Generator;

=pod

=head1 NAME

B<ABNF::Generator> - abstract base class for ABNF-based generators

=head1 INHERITANCE

B<ABNF::Generator> is the root of the Honest and Liar generators

=head1 DESCRIPTION

B<ABNF::Generator> is the abstract base class for ABNF-based generators.

Also it provides function B<asStrings> to stringified generated sequences

=head1 METHODS

=cut

use 5.014;

use strict;
use warnings;
no warnings "recursion";

use Carp;
use Readonly;
use Method::Signatures;
use Data::Dumper;

use Parse::ABNF;
use List::Util qw(shuffle);

use ABNF::Grammar qw($BASIC_RULES splitRule);
use ABNF::Validator;

use base qw(Exporter);
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?)

Creates a new B<ABNF::Generator> object.

$grammar isa B<ABNF::Grammar>.

$validator isa B<ABNF::Validator>.

Children classes can get acces for them by $self->{_grammar} and $self->{_validator}

=cut

method new(ABNF::Grammar $grammar, ABNF::Validator $validator?) {
	my $class = ref($self) || $self;

	croak "Cant create instance of abstract class" if $class eq 'ABNF::Generator';

	$self = {
		_cache => {},
		_grammar => $grammar,
		_validator => $validator || ABNF::Validator->new($grammar)
	};

	bless($self, $class);

	$self->_init();

	return $self;
}

method _init() {
	$self->{handlers} = {
		Range => $self->can("_range"),
		String => $self->can("_string"),
		Literal => $self->can("_literal"),
		Repetition => $self->can("_repetition"),
		ProseValue => $self->can("_proseValue"),
		Reference => $self->can("_reference"),
		Group => $self->can("_group"),
		Choice => $self->can("_choice"),
		Rule => $self->can("_rule"),
	};
}

=pod

=head1 $generator->C<_range>($rule, $recursion)

Generates chain for range element.

Abstract method, most of all children must overload it.

$recursion is a structure to controle recursion depth.

=cut

method _range($rule, $recursion) {
	croak "Range handler is undefined yet";
}

=pod

=head1 $generator->C<_string>($rule, $recursion)

Generates chain for string element.

Abstract method, most of all children must overload it

$recursion is a structure to controle recursion depth.

=cut

method _string($rule, $recursion) {
	croak "String handler is undefined yet";
}

=pod

=head1 $generator->C<_literal>($rule, $recursion)

Generates chain for literal element.

Abstract method, most of all children must overload it

$recursion is a structure to controle recursion depth.

=cut

method _literal($rule, $recursion) {
	croak "Literal handler is undefined yet";
}

=pod

=head1 $generator->C<_repetition>($rule, $recursion)

Generates chain for repetition element.

Abstract method, most of all children must overload it

$recursion is a structure to controle recursion depth.

=cut

method _repetition($rule, $recursion) {
	croak "Repetition handler is undefined yet";
}

=pod

=head1 $generator->C<_reference>($rule, $recursion)

Generates chain for reference element.

Abstract method, most of all children must overload it

$recursion is a structure to controle recursion depth.

=cut

method _reference($rule, $recursion) {
	croak "Reference handler is undefined yet";
}

=pod

=head1 $generator->C<_group>($rule, $recursion)

Generates chain for group element.

Abstract method, most of all children must overload it

$recursion is a structure to controle recursion depth.

=cut

method _group($rule, $recursion) {
	croak "Group handler is undefined yet";
}

=pod

=head1 $generator->C<_choice>($rule, $recursion)

Generates chain for choce element.

Abstract method, most of all children must overload it

$recursion is a structure to controle recursion depth.

=cut

method _choice($rule, $recursion) {
	croak "Choice handler is undefined yet";
}

=pod

=head1 $generator->C<_rule>($rule, $recursion)

Generates chain for rule element, usually -- basic element in chain.

Abstract method, most of all children must overload it

$recursion is a structure to controle recursion depth.

=cut

method _rule($rule, $recursion) {
	croak "Rule handler is undefined yet";
}

=pod

=head1 $generator->C<_generateChain>($rule, $recursion)

Generates one chain per different rule in $rule.

$rule is structure that Return from B<ABNF::Grammar::rule> and like in B<Parse::ABNF>.

$rule might be a command name.

$recursion is a structure to controle recursion depth.

at init it have only one key -- level == 0.

You can create new object perl call or use one.

See use example in ABNF::Generator::Honest in method _choice

=cut

method _generateChain($rule, $recursion) {

	my @result = ();

	if ( ref($rule) ) {
		croak "Bad rule " . Dumper($rule) unless UNIVERSAL::isa($rule, "HASH");
	} elsif ( exists($BASIC_RULES->{$rule}) ) {
		$rule = $BASIC_RULES->{$rule};
	} else {
		$rule = $self->{_grammar}->rule($rule);
	}

	$self->{handlers}->{ $rule->{class} }
	or die "Unknown class " . $rule->{class};

	return $self->{handlers}->{ $rule->{class} }->($self, $rule, $recursion);
}

=pod

=head1 $generator->C<generate>($rule, $tail="")

Generates one sequence string for command $rule. 

Using cache $self->{_cache}->{$rule} for this rule, that speeds up this call.

$rule is a command name.

$tail is a string added to result if it absent.

dies if there is no command like $rule.

=cut

method generate(Str $rule, Str $tail="") {
	croak "Unexisted command" unless $self->{_grammar}->hasCommand($rule);

	$self->{_cache}->{$rule} ||= [];
	unless ( @{$self->{_cache}->{$rule}} ) {
		$self->{_cache}->{$rule} = _asStrings( $self->_generateChain($rule, {level => 0}) );
	}
	my $result = pop($self->{_cache}->{$rule});
	
	my $rx = eval { qr/$tail$/ };
	croak "Bad tail" if $@;
	return $result =~ $rx ? $result : $result . $tail;
}

=pod

=head1 $generator->C<withoutArguments>($name, $tail="")

Return an strings starts like command $name and without arguments.

$tail is a string added to a result.

dies if there is no command like $rule.

=cut

method withoutArguments(Str $name, Str $tail="") {
	croak "Unexisted command" unless $self->{_grammar}->hasCommand($name);

	my ($prefix, $args) = splitRule( $self->{_grammar}->rule($name) );
	
	my $rx = eval { qr/$tail$/ };
	croak "Bad tail" if $@;
	return $prefix =~ $rx ? $prefix : $prefix . $tail;
}

=pod

=head1 $generator->C<hasCommand>($name)

Return 1 if there is a $name is command, 0 otherwise

=cut

method hasCommand(Str $name) {
	$self->{_grammar}->hasCommand($name);
}

=pod

=head1 FUNCTIONS

=head1 C<_asStrings>($generated)

Return stringification of genereted sequences from C<_generateChain>.

Uses in generate call to stringify chains.

=cut

func _asStrings($generated) {
	given ( $generated->{class} ) {
		when ( "Atom" ) { return [ $generated->{value} ] }

		when ( "Sequence" ) {
			my $value = $generated->{value};
			return [] unless @$value;

			my $begin = _asStrings($value->[0]);

			for ( my $pos = 1; $pos < @$value; $pos++ ) {
				my @new_begin = ();
				my $ends = _asStrings($value->[$pos]);
				next unless @$ends;

				my @ibegin = splice([shuffle(@$begin)], 0, $CHOICE_LIMIT);
				my @iends = splice([shuffle(@$ends)], 0, $CHOICE_LIMIT);
				foreach my $end ( @iends ) {
					foreach my $begin ( @ibegin ) {
						push(@new_begin, $begin . $end);
					}
				}
		
				$begin = \@new_begin;
			}

			return $begin;
		}

		when ( "Choice" ) {
			return [
				map { @{_asStrings($_)} } @{$generated->{value}}
			];
		}

		default { die "Unknown class " . $generated->{class} . Dumper $generated }
	}
}

1;

=pod

=head1 AUTHOR / COPYRIGHT / LICENSE

Copyright (c) 2013 Arseny Krasikov <nyaapa@cpan.org>.

This module is licensed under the same terms as Perl itself.

=cut

 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

# -*- perl -*-

# Copyright (c) 2008 by AdCopy
# Author: Jeff Weisberg
# Created: 2008-Dec-19 10:12 (EST)
# Function: read simple config file
#
# $Id$

# file:
# keyword value
# ...

package AC::ConfigFile::Simple;
use AC::Misc;
use AC::DC::Debug;
use Socket;
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

# -*- perl -*-
# example filelist

# $Id: filelist.pm,v 1.1 2010/11/01 19:04:21 jaw Exp $

package Local::MrMagoo::FileList;
use AC::ISOTime;
use AC::Yenta::Direct;
use JSON;
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

# -*- perl -*-
# example myself

# $Id$

package Local::Yenta::MySelf;
use Sys::Hostname;
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

package ACL::Lite;

use 5.006;
use strict;
use warnings;

=head1 NAME

ACL::Lite - Liteweight and flexible ACL checks

=head1 VERSION

Version 0.0004

=cut

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.

C<ACL> stands for "Access Control Lists".

=head2 DEFAULT PERMISSION

The default permission depends on whether you pass a C<uid> (authenticated)
or not (anonymous).

=head1 CONSTRUCTOR

=head2 new

Creates an ACL::Lite object by passing the following parameters:

=over 4

=item uid

User identifier for authenticated users.

=item permissions

Granted permissions.

=item separator

Separator used to parse permission strings. Defaults to C<,>.

=back

=cut

sub new {
	my ($class, $self, $type, %args);
	
	$class = shift;

	%args = @_;
	
	$self = {separator => $args{separator} || ',',
			 permissions => {},
			 uid => $args{uid},
			 volatile => 0};
	
	bless $self, $class;
	
	if (exists $args{permissions}) {
		$type = ref($args{permissions});

		if ($type eq 'ARRAY') {
			for my $perm (@{$args{permissions}}) {
				$self->{permissions}->{$perm} = 1;
			}
		}
		elsif ($type eq 'CODE') {
			$self->{volatile} = 1;
			$self->{sub} = $args{permissions};
		}
		elsif (defined $args{permissions}) {
			my @perms;

			for my $perm (split(/$self->{separator}/, $args{permissions})) {
				$perm =~ s/^\s+//;
				$perm =~ s/\s+$//;
				next unless length($perm);

				$self->{permissions}->{$perm} = 1;
			}
		}
	}

    # add default permissions
    if ($self->{uid}) {
        $self->{permissions}->{authenticated} = 1;
    }
    else {
        $self->{permissions}->{anonymous} = 1;
    }

	return $self;
}

=head2 check $permissions, $uid

Checks whether any of the permissions in $permissions is granted.
Returns first permission which grants access.

=cut

sub check {
	my ($self, $permissions, $uid) = @_;
	my (@check, $user_permissions);

	if (ref($permissions) eq 'ARRAY') {
		@check = @$permissions;
	}
	else {
		@check = ($permissions);
	}

	if ($uid && $uid ne $self->{uid}) {
		# mismatch on user identifier
		return;
	}

    $user_permissions = $self->permissions;

	for my $perm (@check) {
		if (exists $user_permissions->{$perm}) {
			return $perm;
		}
	}

	return;
}

=head2 permissions

Returns permissions as hash reference:

    $perms = $acl->permissions;

Returns permissions as list:

    @perms = $acl->permissions;

=cut

sub permissions {
    my ($self) = @_;

    if ($self->{volatile}) {
        $self->{permissions} = $self->{sub}->();
    }

    if (wantarray) {
        return keys %{$self->{permissions}};
    }

    return $self->{permissions};
}

=head1 CAVEATS

Please anticipate API changes in this early state of development.

=head1 AUTHOR

Stefan Hornburg (Racke), C<racke@linuxia.de>

=head1 BUGS

Please report any bugs or feature requests to C<bug-acl-lite at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=ACL-Lite>.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc ACL::Lite


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker (report bugs here)

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=ACL-Lite>

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/ACL-Lite>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/ACL-Lite>

=item * Search CPAN

L<http://search.cpan.org/dist/ACL-Lite/>

=back


=head1 ACKNOWLEDGEMENTS


=head1 LICENSE AND COPYRIGHT

Copyright 2011-2013 Stefan Hornburg (Racke).

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.


=cut

1; # End of ACL::Lite

 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

#!/usr/bin/perl
#
use IO::Socket;
use threads;
use Proc::Daemon;
use Sys::Syslog qw( :DEFAULT setlogsock);

use Data::Dumper;
use lib( "./" );
use ACL;

# Global config settings
my $TC = 1;
my $debug = 1;
my $port = 12345;
our $pidfile = "/var/run/postfix-policy-server.pid";
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';

# Attempt to parse in the redirect config

$SIG{INT} = \&handle_sig_int;

# Ignore client disconnects
$SIG{PIPE} = "IGNORE";

open PID, "+>", "$pidfile" or die("Cannot open $pidfile: $!\n");
print PID "$$";
close( PID );

my $server = IO::Socket::INET->new(
    LocalPort => $port,
    Type      => SOCK_STREAM,
    Reuse     => 1,
    Listen    => 10
  )
  or die
  "Couldn't be a tcp server on port $default_config->{serverport} : $@\n";

# Generate a number of listener threads
my @threads = ();
for( 1 .. $TC ){
	my $thread = threads->create( \&process_client, $server );
	push( @threads, $thread );
}

foreach my $thread ( @threads ){
	$thread->join();
}

unlink( $pidfile );
closelog;
exit( 0 );

 view all matches for this distribution


ACME-CPANPLUS-Module-With-Core-PreReq

 view release on metacpan or  search on metacpan

lib/ACME/CPANPLUS/Module/With/Core/PreReq.pm  view on Meta::CPAN

package ACME::CPANPLUS::Module::With::Core::PreReq;
$ACME::CPANPLUS::Module::With::Core::PreReq::VERSION = '0.06';
#ABSTRACT: Fake module with a prereq that is a core module for testing CPANPLUS

use strict;
use warnings;

qq[Nobody here but us chickens];

__END__

=pod

=encoding UTF-8

=head1 NAME

ACME::CPANPLUS::Module::With::Core::PreReq - Fake module with a prereq that is a core module for testing CPANPLUS

=head1 VERSION

version 0.06

=head1 SYNOPSIS

 # erm

 cpanp -i ACME::CPANPLUS::Module::With::Core::PreReq

=head1 DESCRIPTION

ACME::CPANPLUS::Module::With::Core::PreReq is a fake module that has a prerequisite of a core module
so I can test something in L<CPANPLUS> and L<CPANPLUS::YACSmoke>

No moving parts and nothing to see.

=head1 AUTHOR

Chris Williams <chris@bingosnet.co.uk>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2017 by Chris Williams.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut

 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

package ACME::Dzil::Test::daemon;

# Module version
our $VERSION = '0.001';

# Perl minimum version
use v5.28.0;

# Sanity restraints
use strict;
use warnings;

# Modern signatures
use experimental 'signatures';



1;

=head1 NAME

ACME::Dzil::Test::daemon - Module abstract placeholder text

=head1 SYNOPSIS

=for comment Brief examples of using the module.

=head1 DESCRIPTION

=for comment The module's description.

=head1 AUTHOR

Paul G Webster <paul.g.webster@googlemail.com>

=head2 IRC

* irc.libera.org #perl 'daemon'

=head1 COPYRIGHT AND LICENSE

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

package ACME::Dzil::Test::daemon2;

# Module version
our $VERSION = '0.001';

# Perl minimum version
use v5.28.0;

# Sanity restraints
use strict;
use warnings;

# Modern signatures
use experimental 'signatures';



1;

=head1 NAME

ACME::Dzil::Test::daemon2 - Module abstract placeholder text

=head1 SYNOPSIS

=for comment Brief examples of using the module.

=head1 DESCRIPTION

=for comment The module's description.

=head1 AUTHOR

Paul G Webster <paul.g.webster@googlemail.com>

=head2 IRC

* irc.libera.org #perl 'daemon'

=head1 COPYRIGHT AND LICENSE

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

package ACME::Error::31337;

use strict;
no  strict 'refs';

use vars q[$VERSION];
$VERSION = '0.01';

use Lingua::31337 qw[text231337];

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

1;
__END__

=head1 n4Me

ACME::Error::31337 - ACM3::ERRoR b4ck3ND To tR4NSl4T3 erRorS 7O co0l 74Lk

=head1 sYn0PS1S

  use ACME::Error::31337;

  die "You stink!";

=head1 DEScR1Pt10N

CoNv3R7 y0Ur 3RR0rS 7o 31173 spE3cH.

US3 C<$Lingua::31337::LEVEL> 70 rA1sE OR 10W3r YoUR L3vel of 31I7eNess.

=head1 auTH0R

CAS3y W3ST <f<CaseY@geeKNEst.Com>>

=head1 cOpyRiGH7

COpYRiGht (C) 2002 C4s3Y R. weSt <C4seY@G33kneSt.cOM>.  4l1
r1gH7S ResERVED.  7h1S PR0grAm 1S pHr3E sOPhTW4RE; YoU c4n
red1S7rIBuT3 17 AND/0R m0dIpHy It UnDEr th3 SaMe TeRMS aS
Per1 itSE1F.

=head1 s3e aLSo

p3rl(1), AcM3::eRROr, L1NGu4::31337.

=cut

 view all matches for this distribution


ACME-Error-Coy

 view release on metacpan or  search on metacpan

Coy.pm  view on Meta::CPAN

package ACME::Error::Coy;

use strict;
no  strict 'refs';

use vars q[$VERSION];
$VERSION = '0.01';

use Coy;

*die_handler  = $SIG{__DIE__};
*warn_handler = $SIG{__WARN__};


1;
__END__
# Below is stub documentation for your module. You better edit it!

=head1 NAME

ACME::Error::Coy - Perl extension for blah blah blah

=head1 SYNOPSIS

  use ACME::Error Coy;

=head1 DESCRIPTION

Interface to L<Coy> for printing your errors.

=head1 AUTHOR

Casey West <F<casey@geeknest.com>>

=head1 COPYRIGHT

Copyright (c) 2002 Casey R. West <casey@geeknest.com>.  All
rights reserved.  This program is free software; you can
redistribute it and/or modify it under the same terms as
Perl itself.

=head1 SEE ALSO

perl(1), L<Coy>.

=cut

 view all matches for this distribution


ACME-Error-HTML

 view release on metacpan or  search on metacpan

HTML.pm  view on Meta::CPAN

package ACME::Error::HTML;

use strict;
no  strict 'refs';

use vars q[$VERSION];
$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__

=head1 NAME

ACME::Error::HTML - ACME::Error Backend to Markup Errors with HTML

=head1 SYNOPSIS

  use ACME::Error HTML;

  warn "blink"; # <p>blink</p>

=head1 DESCRIPTION

Converts your errors to HTML.

=head1 AUTHOR

Casey West <F<casey@geeknest.com>>

=head1 COPYRIGHT

Copyright (c) 2002 Casey R. West <casey@geeknest.com>.  All
rights reserved.  This program is free software; you can
redistribute it and/or modify it under the same terms as
Perl itself.

=head1 SEE ALSO

perl(1), HTML::FromText.

=cut

 view all matches for this distribution


ACME-Error-IgpayAtinlay

 view release on metacpan or  search on metacpan

IgpayAtinlay.pm  view on Meta::CPAN

package ACME::Error::IgpayAtinlay;

use strict;
no  strict 'refs';

use vars q[$VERSION];
$VERSION = '0.01';

use Lingua::Atinlay::Igpay qw[:all];

*die_handler = *warn_handler = sub {
  my @errors = @_;
  return enhay2igpayatinlay @errors;
};

1;
__END__

=head1 AMENAY

ACMEHAY::Errorhay::IgpayAtinlayhay - ACMEHAY::Errorhay Ackendbay otay Onvertcay Errorshay otay Igpay Atinlay

=head1 OPSISSYNAY

  usehay ACMEHAY::Errorhay => IgpayAtinlayhay;

  arnway "Adbay"; # Adbayhay

=head1 ESCRIPTIONDAY

Onvertscay ouryay errorshay otay Igpay Atinlay.

=head1 AUTHORHAY

Aseycay Estway <F<aseycay@eeknestgay.omcay>>

=head1 OPYRIGHTCAY

Opyrightcay (c) 2002 Aseycay R. Estway <aseycay@eeknestgay.omcay>.  Allhay
ightsray eservedray.  Isthay ogrampray ishay eefray oftwaresay; ouyay ancay
edistributeray ithay andhay/orhay odifymay ithay underhay ethay amesay ermstay ashay
Erlpay itselfhay.

=head1 EESAY ALSOHAY

erlpay(1), Ingualay::Atinlayhay::Igpayhay.

=cut

 view all matches for this distribution


ACME-Error-Translate

 view release on metacpan or  search on metacpan

Translate.pm  view on Meta::CPAN

package ACME::Error::Translate;

use strict;
no  strict 'refs';

use vars qw[$VERSION];
$VERSION = '0.01';

use Lingua::Translate;

{
  my $translator = undef;
  sub import {
    my $class = shift;
    $translator = Lingua::Translate->new( src => 'en', dest => shift );
  }

  *die_handler = *warn_handler = sub {
    if ( $translator ) {
      return map $translator->translate( $_ ), @_;
    } else {
      return @_;
    }
  };
}

1;
__END__

=head1 NAME

ACME::Error::Translate - Language Translating Backend for ACME::Error

=head1 SYNOPSIS

  use ACME::Error Translate => de;

  die "Stop!"; # Anschlag!

=head1 DESCRIPTION

Translates error messages from the default English to the language of your
choice using L<Lingua::Translate>.  As long as the backend used by
L<Lingua::Translage> understands your two letter language code, you're ok.

By default the backend is Babelfish.

=head1 AUTHOR

Casey West <F<casey@geeknest.com>>

=head1 SEE ALSO

perl(1), ACME::Error, Lingua::Translate.

=cut

 view all matches for this distribution


ACME-Error

 view release on metacpan or  search on metacpan

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

package ACME::Error;

use strict;

use vars qw[$VERSION];
$VERSION = '0.03';

sub import {
  my $class = shift;
  if ( my $style = shift ) {
    my $package = qq[ACME::Error::$style];
    my $args    = join q[', '], @_;
    eval qq[use $package '$args'];
    die $@ if $@;
    
    my $nested = -1;

    { no strict 'refs';
      $SIG{__WARN__} = sub {
        local $SIG{__WARN__};
        $nested++;
        my $handler = $package . q[::warn_handler];
        warn &{$handler}(@_) unless $nested;
        warn @_ if $nested;
        $nested--;
      };

      $SIG{__DIE__}  = sub {
        local $SIG{__DIE__};
        $nested++;
        my $handler = $package . q[::die_handler];
        die &{$handler}(@_) unless $nested;
        die @_ if $nested;
        $nested--;
      };
    }

#    $SIG{__WARN__} = sub {
#      my $handler = $package . q[::warn_handler];
#      {
#       no strict 'refs';
#       warn &{$handler} , "\n" if exists &{$handler};
#      }
#    };

#    $SIG{__DIE__}  = sub {
#      my $handler = $package . q[::die_handler];
#      {
#       no strict 'refs';
#       die &{$handler}, "\n" if exists &{$handler};
#      }
#    };
  }
}

1;
__END__

=head1 NAME

ACME::Error - Never have boring errors again!

=head1 SYNOPSIS

  use ACME::Error SHOUT;
  
  warn "Warning"; # WARNING!

=head1 DESCRIPTION

C<ACME::Error> is a front end to Perl error styles.  C<$SIG{__WARN__}> and C<$SIG{__DIE__}>
are intercepted.  Backends are pluggable.  Choose a backend by specifying it when you
C<use ACME::Error SomeStyle>;

=head2 Writing Backends

Writing backends is easy.  See L<ACME::Error::SHOUT> for a simple example.  Basically your
backend needs to be in the C<ACME::Error> namespace and defines just two subroutines, C<warn_handler>
and C<die_handler>.  The arguments passed to your subroutine are the same as those passed to the signal
handlers, see L<perlvar> for more info on that.  You are expected to C<return> what you want to be
C<warn>ed or C<die>d.

You can also run use an C<import> function.  All arguments passed to C<ACME::Error> after
the style to use will be passed to the backend.

=head1 AUTHOR

Casey West <F<casey@geeknest.com>>

=head1 COPYRIGHT

Copyright (c) 2002 Casey R. West <casey@geeknest.com>.  All
rights reserved.  This program is free software; you can
redistribute it and/or modify it under the same terms as
Perl itself.

=head1 SEE ALSO

perl(1).

=cut

 view all matches for this distribution


ACME-MBHall

 view release on metacpan or  search on metacpan

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

package ACME::MBHall;

use 5.006;
use strict;
use warnings;

=head1 NAME

ACME::MBHall - The great new ACME::MBHall!

=head1 VERSION

Version 0.03

=cut

our $VERSION = '0.03';


=head1 SYNOPSIS

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.

=head1 SUBROUTINES/METHODS

=head2 sum( LIST_OF_NUMBERS )

Returns the sum of the numbers.

=cut

sub sum {
	my $sum = 0;
	foreach my $value (@_) {
		$sum+=$value;
	}
	return $sum;
}

=head2 function2

=cut

sub function2 {
}

=head1 AUTHOR

Matthew Hall, C<< <MBHall at cpan.org> >>

=head1 BUGS

Please report any bugs or feature requests to C<bug-acme-mbhall at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=ACME-MBHall>.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.




=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc ACME::MBHall


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker (report bugs here)

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=ACME-MBHall>

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/ACME-MBHall>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/ACME-MBHall>

=item * Search CPAN

L<http://search.cpan.org/dist/ACME-MBHall/>

=back


=head1 ACKNOWLEDGEMENTS


=head1 LICENSE AND COPYRIGHT

Copyright 2012 Matthew Hall.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.


=cut

1; # End of ACME::MBHall

 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

package ACME::MSDN::SPUtility;

use warnings;
use strict;

use Perl6::Say;

=encoding utf8

=head1 NAME

ACME::MSDN::SPUtility - SPUtility.HideTaiwan Method (Microsoft.SharePoint.Utilities)

=head1 VERSION

Version 0.04

=cut

our $VERSION = '0.04';


=head1 SYNOPSIS

This is a Implementation of part of MSDN SPUtility.
L<http://msdn.microsoft.com/en-us/library/ms441219.aspx>

This module does the following things:
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> >>

=head1 BUGS

Please report any bugs or feature requests to C<bug-acme-msdn-sputility at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=ACME-MSDN-SPUtility>.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.




=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc ACME::MSDN::SPUtility


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=ACME-MSDN-SPUtility>

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/ACME-MSDN-SPUtility>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/ACME-MSDN-SPUtility>

=item * Search CPAN

L<http://search.cpan.org/dist/ACME-MSDN-SPUtility>

=back


=head1 ACKNOWLEDGEMENTS


=head1 COPYRIGHT & LICENSE

Copyright 2009 BlueT - Matthew Lien - 練喆明, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.


=cut

1; # End of ACME::MSDN::SPUtility

 view all matches for this distribution


ACME-MyFirstModule-SETHS

 view release on metacpan or  search on metacpan

lib/ACME/MyFirstModule/SETHS.pm  view on Meta::CPAN

package ACME::MyFirstModule::SETHS;

use 5.006;
use strict;
use warnings;


=head1 NAME

ACME::MyFirstModule::SETHS - The great new ACME::MyFirstModule::SETHS!

=head1 VERSION

Version 0.03

=cut

our $VERSION = '0.03';


=head1 SYNOPSIS

Quick summary of what the module does.

Perhaps a little code snippet.

    use ACME::MyFirstModule::SETHS;

    my $foo = ACME::MyFirstModule::SETHS->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.

=head1 SUBROUTINES/METHODS

=head2 function1

=cut

sub function1 {
}

=head2 function2

=cut

sub function2 {
}

=head1 AUTHOR

Seth Surchin, C<< <sas0199 at gmail.com> >>

=head1 BUGS

Please report any bugs or feature requests to C<bug-acme-myfirstmodule-seths at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=ACME-MyFirstModule-SETHS>.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.




=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc ACME::MyFirstModule::SETHS


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker (report bugs here)

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=ACME-MyFirstModule-SETHS>

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/ACME-MyFirstModule-SETHS>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/ACME-MyFirstModule-SETHS>

=item * Search CPAN

L<http://search.cpan.org/dist/ACME-MyFirstModule-SETHS/>

=back


=head1 ACKNOWLEDGEMENTS


=head1 LICENSE AND COPYRIGHT

Copyright 2015 Seth Surchin.

This program is free software; you can redistribute it and/or modify it
under the terms of the the Artistic License (2.0). You may obtain a
copy of the full license at:

L<http://www.perlfoundation.org/artistic_license_2_0>

Any use, modification, and distribution of the Standard or Modified
Versions is governed by this Artistic License. By using, modifying or
distributing the Package, you accept this license. Do not use, modify,
or distribute the Package, if you do not accept this license.

If your Modified Version has been derived from a Modified Version made
by someone other than you, you are nevertheless required to ensure that
your Modified Version complies with the requirements of this license.

This license does not grant you the right to use any trademark, service
mark, tradename, or logo of the Copyright Holder.

This license includes the non-exclusive, worldwide, free-of-charge
patent license to make, have made, use, offer to sell, sell, import and
otherwise transfer the Package with respect to any patent claims
licensable by the Copyright Holder that are necessarily infringed by the
Package. If you institute patent litigation (including a cross-claim or
counterclaim) against any party alleging that the Package constitutes
direct or contributory patent infringement, then this Artistic License
to you shall terminate on the date that such litigation is filed.

Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER
AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES.
THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY
YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR
CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR
CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE,
EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.


=cut

1; # End of ACME::MyFirstModule::SETHS

 view all matches for this distribution


ACME-PM-Voronezh

 view release on metacpan or  search on metacpan

lib/ACME/PM/Voronezh.pm  view on Meta::CPAN

package ACME::PM::Voronezh;

use warnings;
use strict;

=head1 NAME

ACME::PM::Voronezh - Talks by Voronezh.pm

=head1 VERSION

Version 0.02

=cut

our $VERSION = '0.02';


=head1 SYNOPSIS

Welcome to Voronezh.PM!


=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc ACME::PM::Voronezh


You can also look for information at:

=over 4

=item * Voronezh.PM

L<http://voronezh.pm.org/>

=item * Mailing list

L<http://groups.google.com/group/voronezh-pm>

=item * Twitter

L<http://twitter.com/voronezh_pm>

=item * Search CPAN

L<http://search.cpan.org/dist/ACME-PM-Voronezh/>

=back


=head1 AUTHOR

Alexander Nusov, C<< <alexander.nusov+cpan at gmail.com> >>


=head1 ACKNOWLEDGEMENTS

I am grateful to Dmitry Degtyarev C<< <degtyarev.dm at gmail.com> >> who inspired the idea of creating the group.


=head1 LICENSE AND COPYRIGHT

Copyright 2010 Alexander Nusov.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.


=cut

1; # End of ACME::PM::Voronezh

 view all matches for this distribution


ACME-QuoteDB

 view release on metacpan or  search on metacpan

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

#$Id: QuoteDB.pm,v 1.36 2009/09/30 07:37:09 dinosau2 Exp $
# /* vim:et: set ts=4 sw=4 sts=4 tw=78: */

package ACME::QuoteDB;

use 5.008005;        # require perl 5.8.5, re: DBD::SQLite Unicode
use warnings;
use strict;

#major-version.minor-revision.bugfix
use version; our $VERSION = qv('0.1.2');

#use criticism 'brutal'; # use critic with a ~/.perlcriticrc

use Exporter 'import';
our @EXPORT = qw/quote/; # support one liner

use Carp qw/croak/;
use Data::Dumper qw/Dumper/;
use ACME::QuoteDB::LoadDB;
use aliased 'ACME::QuoteDB::DB::Attribution' => 'Attr';
use aliased 'ACME::QuoteDB::DB::QuoteCatg'  => 'QuoteCatg';
use aliased 'ACME::QuoteDB::DB::Category'  => 'Catg';
use aliased 'ACME::QuoteDB::DB::Quote'    => 'Quote';

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.';


__END__

=head1 NAME

ACME::QuoteDB - API implements CRUD for a Collection of Quotes (adages/proverbs/sayings/epigrams, etc)


=head1 VERSION

Version 0.1.2


=head1 SYNOPSIS

Easy access to a collection of quotes (the 'Read' part)

As quick one liner:

    # randomly display one quote from all available. (like motd, 'fortune')
    perl -MACME::QuoteDB -le 'print quote()'

    # Say you have populated your quotes database with some quotes from 
    # 'The Simpsons'
    # randomly display one quote from all available for person 'Ralph'
    perl -MACME::QuoteDB -le 'print quote({AttrName => "ralph"})'

    # example of output
    Prinskipper Skippel... Primdable Skimpsker... I found something!
    -- Ralph Wiggum

    # get 1 quote, only using these categories (you have defined)
    perl -MACME::QuoteDB -le 'print quote({Category => [qw(Humor Cartoon ROTFLMAO)]})'


In a script/module, OO usage:

    use ACME::QuoteDB;

    my $sq = ACME::QuoteDB->new;

    # get random quote from any attribution
    print $sq->get_quote; 

    # get random quote from specified attribution
    print $sq->get_quote({AttrName => 'chief wiggum'}); 

    # example of output
    I hope this has taught you kids a lesson: kids never learn.
    -- Chief Wiggum

    # get all quotes from one source
    print @{$sq->get_quotes({Source => 'THE SimPSoNs'})}; # is case insensitive

    # get 2 quotes, with a low rating that contain a specific string
    print @{$sq->get_quotes_contain({
                  Contain =>  'til the cow',
                  Rating  => '1-5',
                  Limit   => 2
            })};

    # get 5 quotes from given source
    print @{$sq->get_quotes({Source => 'The Simpsons',
                             Limit  => 5
           })};

    # list all sources
    print $sq->list_attr_sources;

    # list all categories
    print $sq->list_categories;


=head1 DESCRIPTION

This module provides an easy to use programmitic interface 
to a database (sqlite3 or mysql) of 'quotes'.  (any content really, 
that can fit into our L<"defined format"|/"record format">)

For simplicty you can think of it as a modern fancy perl version 
of L<fortune|/fortune> 
(with a management interface, remote database
connection support, 
plus additional features and some not (yet) supported)

Originally, this module was designed for a collection of quotes from a well 
known TV show, once I became aware that distributing it as such would be 
L<copyright infringement|/'copyright infringement'>, I generalized the module, so it can be loaded 
with 'any' content. (in the quote-ish L<format|/"record format">)

=head4 Supported actions include: (CRUD)

=over 4

=item 1 Create

       * Adding quote(s)
       * 'Batch' Loading quotes from a file (stream, other database, etc)

=item 1 Read

       * Displaying a single quote, random or based on some criteria
       * Displaying multiple quotes, based on some criteria
       * Displaying a specific number of quotes, based on some search criteria

=item 1 Update

       * Update an existing quote

=item 1 Delete

       * Remove an existing quote

=back


=head4 Examples of L<Read|/Read>

    my $sq = ACME::QuoteDB->new;

    # on Oct 31st, one could get an appropriate (humorous) quote:
    # (providing, of course that you have defined/populated these categories)
    print $sq->get_quote({Category => [qw(Haloween Humor)]}); 

    # get everthing from certain attributor:
    print @{$sq->get_quotes({AttrName => 'comic book guy'})};

    # get all quotes with a certain rating
    $sq->get_quotes({Rating => '7.0'});

    # get all quotes containing some specific text:
    $sq->get_quotes_contain({Contain => 'til the cow'});


=head4 Examples of L<Create|/Create>

(See L<ACME::QuoteDB::LoadDB> for batch loading)
 
    # add a quote to the database
    my $id_of_added = $sq->add_quote({
                          Quote     => 'Hi, I'm Peter,...",
                          AttrName  => 'Peter Griffin',
                          Source    => 'Family American Dad Guy',
                          Rating    => '1.6',
                          Category  => 'TV Humor',
                      });

=head4 Example of L<Update|/Update>

    # update a quote in the database
    my $quote_id = $sq->get_quote_id({Quote => 'Hi, I'm Peter,..."});

    $sq->update_quote({
        QuoteId   => $quote_id,
        Quote     => 'Hi, I'm Peter, and your not!',
        AttrName  => 'Peter Griffin',
        Source    => 'Family Guy',
        Rating    => '5.7',
        Category  => [qw(TV Humor Crude Adolescent)]
    });

    # category/quote is a many to many relationship: 
    # 1 quote can be in many categories. (and of course 1 category can have many quotes)


=head4 Example of L<Delete|/Delete>

    # delete a quote from the database
    $sq->delete_quote({QuoteId => $quote_id});
    

=over 2

=item record format

One full quote database record currently consits of 5 fields:

Quote, AttrName, Source, Rating, Category

    Quote     => 'the quote desired' # mandatory
    AttrName  => 'who said it'       # mandatory
    Source    => 'where was it said'
    Rating    => 'how you rate the quote/if at all',
    Category  => 'what category is the quote in',

For example:

    Quote     => 'Hi, I'm Peter,...",
    AttrName  => 'Peter Griffin',
    Source    => 'Family Guy',
    Rating    => '8.6',
    Category  => 'TV Humor',

=item * NOTE: In order for this module to be useful one has to load some quotes
 to the database.  Hey, just once though :) (see below - L<Loading Quotes|/"LOADING QUOTES">)

=back

=head1 OVERVIEW

Easy, quick auto-CRUD access to a collection of quotes. (which you provide)

Some ideal uses for this module could be:

=over 4

=item 1 

Quotes Website (quotes/movie/lyrics/limerick/proverbs/jokes/etc)

=item 2 

perl replacement for 'fortune'

=item 3 

Dynamic signature generation

=item 4 

international languages (has utf8 support)

=item 5 

convenient storing/sharing collections of quotes

=item 6 

for me to finally have a place to store (and manage) quotes (that can
be easily backed up or even to a remote db if desired)

=item 7 

anywhere perl is supported and 'quotes' are desired.

=item 8

others? (let me know what you do, if you want, if you do)

=back

See L</DESCRIPTION> above

Also see L<ACME::QuoteDB::LoadDB>


=head1 USAGE

    use ACME::QuoteDB;

    my $sq = ACME::QuoteDB->new;

    print $sq->get_quote;

    # examples are based on quotes data in the test database. 
    # (see tests t/data/)

    # get specific quote based on basic text search.
    # search all 'ralph' quotes for string 'wookie'
    print $sq->get_quotes_contain({
                  Contain   => 'wookie', 
                  AttrName => 'ralph',
                  Limit     => 1          # only return 1 quote (if any)
           });
    # output:
    I bent my wookie.
    -- Ralph Wiggums

    # returns all quotes attributed to 'ralph', with a rating between 
    # (and including) 7 to 9
    print join "\n",  @{$sq->get_quotes({
                                          AttrName => 'ralph', 
                                          Rating    => '7-9'
                                        })
                       };
    
    # same thing but limit to 2 results returned
    # (and including) 7 to 9
    print join "\n",  @{$sq->get_quotes({
                                          AttrName => 'ralph', 
                                          Rating    => '7-9',
                                          Limit     => 2
                                         })
                       };

    # get 6 random quotes (any attribution)
    foreach my $q ( @{$sq->get_quotes({Limit => 6})} ) {
        print "$q\n";
    }


    # get list of available attributions (that have quotes provided by this module)
    print $sq->list_attr_names;

    # any unique part of name will work
    # i.e these will all return the same results (because of our limited
    # quotes db data set)
    print $sq->get_quotes({AttrName => 'comic book guy'});
    print $sq->get_quotes({AttrName => 'comic book'});
    print $sq->get_quotes({AttrName => 'comic'});
    print $sq->get_quotes({AttrName => 'book'});
    print $sq->get_quotes({AttrName => 'book guy'});
    print $sq->get_quotes({AttrName => 'guy'});

   # get all quotes, only using these categories (you have defined)
   print @{$sq->get_quotes({ Category => [qw(Humor ROTFLMAO)] })};

   # get all quotes from Futurama
   print @{$sq->get_quotes({Source => Futurama})};


Also see t/02* included with this distribution.
(available from the CPAN if not included on your system)


=head1 SUBROUTINES/METHODS 

For the most part this is an OO module. There is one function (quote) provided
for command line 'one liner' convenience. 

=head2 quote
    
    returns one quote. (is exported).
    this takes identical arguments to 'get_quote'. (see below)
     
    example:

    perl -MACME::QuoteDB -le 'print quote()'

=head2 new

    instantiate a ACME::QuoteDB object.

    takes no arguments

    # example
    my $sq = ACME::QuoteDB->new;

=head2 get_quote
     
    returns one quote

    # get random quote from any attribution
    print $sq->get_quote;

    # get random quote from specified attribution
    print $sq->get_quote({AttrName => 'chief wiggum'});

    Optional arguments, a hash ref.

    available keys: AttrName, Rating

    my $args_ref = {
                     AttrName => 'chief wiggum'
                     Rating    => 7,
                    };

    print $sq->get_quote($args_ref);

    Note: The 'Rating' option is very subjective. 
    It's a 0-10 scale of 'quality' (or whatever you decide it is)

    To get a list of the available AttrNames use the list_attr_names method
    listed below.  
    
    Any unique part of name will work

    Example, for attribution 'comic book guy'

    # these will all return the same results
    print $sq->get_quotes({AttrName => 'comic book guy'});

    print $sq->get_quotes({AttrName => 'comic book'});

    print $sq->get_quotes({AttrName => 'comic'});

    print $sq->get_quotes({AttrName => 'book'});

    print $sq->get_quotes({AttrName => 'book guy'});

    print $sq->get_quotes({AttrName => 'guy'});
 
    # However, keep in mind the less specific the request is the more results
    # are returned, for example the last one would match, 'Comic Book Guy', 
    # 'Buddy Guy' and 'Guy Smiley',...

=begin comment
    
    # XXX this is a bug with sub _get_attribution_ids_from_name 
    #print $sq->get_quotes({AttrName => 'guy'}); would not match 'Guy Smiley'

=end comment

=head2 add_quote
     
    Adds the supplied record to the database

    possible Key arguments consist of:
        Quote, AttrName, Source, Rating, Category  

    with only Quote and AttrName being mandatory (all are useful though):

    For Example: 

      my $q = 'Lois: Peter, what did you promise me?' .
      "\nPeter: That I wouldn't drink at the stag party." .
      "\nLois: And what did you do?" .
      "\nPeter: Drank at the stag pa-- ... Whoa. I almost walked into that one.";
      
      $sq->add_quote({
          Quote     => $q,
          AttrName  => 'Peter Griffin',
          Source    => 'Family Guy',
          Rating    => '8.6',
          Category  => 'TV Humor',
      });


=head2 get_quote_id (very beta)
 
   given a (verbatim) quote, will retrieve that quotes id
   (only useful for then doing an L</update> or L</delete>

   possible Key arguments consist of: Quote

   my $q = 'Lois: Peter, what did you promise me?' .
  "\nPeter: That I wouldn't drink at the stag party." .
  "\nLois: And what did you do?" .
  "\nPeter: Drank at the stag pa-- ... Whoa. I almost walked into that one.";
  
  my $qid = $sq->get_quote_id({Quote => $q});
  print $qid; # 30

=head2 delete_quote (very beta)

    deletes an existing quote in the database
    takes an valid quote id (see L</get_quote_id>)

    possible Key arguments consist of: QuoteId

      $sq->delete_quote({QuoteId => $qid});


=head2 update_quote (very beta)
     
    updates an existing quote in the database

    possible Key arguments consist of: QuoteId, Quote

      my $q = 'Lois: Peter, what did you promise me?' .
      "\nPeter: That I wouldn't drink at the stag party." .
      "\nLois: And what did you do?" .
      "\nPeter: Drank at the stag pa-- ... Whoa. I almost walked into that one.";

      $q =~ s/Lois/Marge/xmsg;
      $q =~ s/Peter/Homer/xmsg;
 
      $sq->update_quote({
          QuoteId   => $qid, # as returned from L</get_quote_id>
          Quote     => $q,
          AttrName  => 'Lois Simpson',
          Source    => 'The Simpsons Guys',
          Rating    => '9.6',
          Category  => 'Sometimes Offensive Humor',
      });


=head2 get_quotes

    returns zero or more quote(s)

    Optional arguments, a hash ref.

    available keys: AttrName, Rating, Limit

    # returns 2 ralph wiggum quotes with a rating between 
    # (and including) 7 to 9
    print join "\n",  @{$sq->get_quotes({
                                          AttrName => 'ralph', 
                                          Rating    => '7-9',
                                          Limit     => 2
                                         })
                       };

    AttrName and Rating work exactely the same as for get_quote (docs above)
    
    Limit specifies the amout of results you would like returned. (just like
    with SQL)


=head2 get_quotes_contain

    returns zero or more quote(s), based on a basic text search.

    # get specific quote based on basic text search.
    # search all ralph wiggum quotes for string 'wookie'
    print $sq->get_quotes_contain({
                  Contain   => 'wookie', 
                  AttrName => 'ralph',
                  Limit     => 1          # only return 1 quote (if any)
           })->[0]; # q{Ralph: I bent my wookie.};


    Optional arguments, a hash ref.

    available keys: AttrName, Contain, Limit

    AttrName and Limit work exactly the same as for get_quotes (docs above)
    
    Contain specifies a text string to search quotes for. If a AttrName
    option is included, search is limited to that attribution.

    Contain is a simple text string only. Regex not supported
    Contain literally becomes: AND quote LIKE '%$contain%'


=head2 list_attr_names

    returns a list of attributions (name) for which we have quotes.

    # get list of available attributions (that have quotes provided by this module)
    print $sq->list_attr_names;


=head2 list_categories

    returns a list of categories defined in the database

    # get list of available categories (that have quotes provided by this module)
    print $sq->list_categories;


=head2 list_attr_sources

    returns a list of attribution sources defined in the database

    # get list of attribution sources (that have quotes provided by this module)
    print $sq->list_attr_sources;


=head1 LOADING QUOTES

In order to actually use this module, one has to load quotes content,
hopefully this is relativly easy,... (see t/01-load_quotes.t in tests)

=over 4

=item 1 add_quote, one record at a time, probably within an iteration loop

see L</add_quote>

=item 1 (Batch Load) load quotes from a csv file. (tested with comma and tab delimiters)

  format of file must be as follows: (headers)
  "Quote", "Attribution Name", "Attribution Source", "Category", "Rating"
 
  for example:
  "Quote", "Attribution Name", "Attribution Source", "Category", "Rating"
  "I hope this has taught you kids a lesson: kids never learn.","Chief Wiggum","The Simpsons","Humor",9
  "Sideshow Bob has no decency. He called me Chief Piggum. (laughs) Oh wait, I get it, he's all right.","Chief Wiggum","The Simpsons","Humor",8

=item 1 if these dont suit your needs, ACME::QuoteDB::LoadDB is sub-classable, 

  so one can extract data anyway they like and populate the db themselves. 
  (there is a test that illustrates overriding the stub method, 'dbload')

   you need to populate a record data structure:

    $self->set_record(quote  => q{}); # mandatory
    $self->set_record(name   => q{}); # mandatory
    $self->set_record(source => q{}); # optional but useful
    $self->set_record(catg   => q{}); # optional but useful
    $self->set_record(rating => q{}); # optional but useful

   # then to write the record you call
   $self->write_record;

   NOTE: this is a record-by-record operation, so one would perform this within a
   loop. there is no bulk (memory dump) write operation currently.


=back


For more see L<ACME::QuoteDB::LoadDB>


=begin comment
 
    keep pod coverage happy.

    # Coverage for ACME::QuoteDB is 71.4%, with 3 naked subroutines:
    # Attr
    # Quote
    # Catg
    # QuoteCatg

    pod tests incorrectly state, Attr, Quote and Catg are subroutines, well they
    are,... (as aliases) but act on a different object. 
    
    TODO: explore the above (is this a bug, if so, who's?, version effected, 
    create use case, etc) 
    
=head2 Attr

=head2 Quote

=head2 Catg

=head2 QuoteCatg

=end comment

=head1 DIAGNOSTICS

An error such as:

C<DBD::SQLite::db prepare_cached failed: no such table: ,...>

probably means that you do not have a database created in the correct format.

basically, you need to create the database, usually, on a first run

you need to add the flag (to the loader):

create_db => 1, # first run, create the db

appending to an existing database is the default behaviour

see L<ACME::QuoteDB::LoadDB/create_db_tables>

=head1 CONFIGURATION AND ENVIRONMENT

if you are running perl > 5.8.5 and have access to
install cpan modules, you should have no problem installing this module
(utf-8 support in DBD::SQLite not avaible until 5.8 - we don't support 'non
utf-8 mode)

=over 1

=item * By default, the quotes database used by this module installs in the 
system path, 'lib', (See L<Module::Build/"INSTALL PATHS">)
as world writable - i.e. 0666 (and probably owned by root)
If you don't like this, you can modify Build.PL to not chmod the file and it
will install as 444/readonly, you can also set a chown in there for whoever
you want to have RW access to the quotes db.

Alternativly, one can specify a location to a quotes database (file) to use.
(Since the local mode is sqlite3, the file doesn't even need to exist, just
needs read/write access to the path on the filesystem)

Set the environmental variable:

$ENV{ACME_QUOTEDB_PATH} (untested on windows)

(this has to be set before trying a database load and also (everytime before 
using this module, obviouly)

Something such as:

BEGIN { 
    # give alternate path to the DB
    # doesn't need to exist, will create
    $ENV{ACME_QUOTEDB_PATH} = '/home/me/my_stuff/my_quote_db'
}

* (NOTE: be sure this (BEGIN) exists *before* the 'use ACME::QuoteDB' lines)

The default is to use sqlite3.

In order to connect to a mysql database, several environmental variables
are required.

BEGIN {
    # have to set this to use remote database
    $ENV{ACME_QUOTEDB_REMOTE} =  'mysql';
    $ENV{ACME_QUOTEDB_DB}     =  'acme_quotedb';
    $ENV{ACME_QUOTEDB_HOST}   =  'localhost';
    $ENV{ACME_QUOTEDB_USER}   =  'acme_user';
    $ENV{ACME_QUOTEDB_PASS}   =  'acme';
}

Set the above in a begin block.

The database connection is transparent. 

Module usage wise, all operations are the same but now
you will be writing to the remote mysql database specified.

(The user will need read/write permissions to the db/tables)
(mysql admin duties are beyond the scope of this module)

The only supported databases at this time are sqlite and mysql.

It is trivial to add support for others

=back

=head1 DEPENDENCIES

L<Carp>

L<Data::Dumper>

L<criticism> (pragma - enforce Perl::Critic if installed)

L<version>(pragma - version numbers)

L<aliased>

L<Test::More>

L<DBD::SQLite>

L<DBI>

L<Class::DBI>

L<File::Basename>

L<Readonly>

L<Cwd>

L<Module::Build>


=head1 INCOMPATIBILITIES

none known of

=head1 SEE ALSO

man fortune (unix/linux)

L<Fortune>

L<fortune>

L<Acme::RandomQuote::Base>

L<WWW::LimerickDB>

=begin comment

    C<Fortune> http://search.cpan.org/~gward/Fortune-0.2/Fortune.pm
    C<fortune> http://search.cpan.org/~cwest/ppt-0.14/bin/fortune
    C<Acme::RandomQuote::Base> http://search.cpan.org/~mangaru/Acme-RandomQuote-Base-0.01/lib/Acme/RandomQuote/Base.pm
    C<WWW::LimerickDB> http://search.cpan.org/~zoffix/WWW-LimerickDB-0.0305/lib/WWW/LimerickDB.pm

=end comment


=head1 AUTHOR

David Wright, C<< <david_v_wright at yahoo.com> >>

=head1 TODO

=over 2

=item 1 if the database cannot be found, no error is printed!!!

or if you have no write access to it!
"you'll just get 'no attribute can be found,,...", which is cryptic to say
the least!

=item 1 add a dump backup to csv

a backup mechanism for your db to a regular text csv file.

=item 1 clean up tests 'skip if module X' not installed

(one of sqlite3 or mysql is required). currently dies if DBD::SQLite not
installed

=item 1 support multiple categories from LoadDB

how to load multipul categories from a csv file? 
(try to avoid somthing ugly in our csv file format). or maybe don't support
this.

=item 1 (possibly) support long/short quotes output (see 'man fortune')

=back


=head1 BUGS AND LIMITATIONS

The CRUD stuff is weak for sure.
(i.e. add_quote, update_quote, delete_quote, get_quote_id)

For example, currently you can only get the quote id from the exact quote

In the future, I may just expose the DBI::Class object directly
to those that need/want it.

=begin comment

get_quotes_contain  uses %search% to do it's pattern mattching, so that will
miss some obvious searches, which it should find.

i.e.
'Bill' will not find 'Bill' , beginning and endings of words will be off.

XXX - look at search_like, instead of what you are doing now

=end comment

currently, I am not encapsulating the record data structure used 
by LoadDB->write. (i.e. it's a typical perl5 ojbect, the blessed hash)

I will for sure be encapsulating all data in a future version.
(so, don't have code that does $self->{record}->{name} = 'value', or you won't
be happy down the road). Instead use $self->get_record('name') (getter) or
$self->set_record(name => 'my attrib') (setter)


When we are using a SQLite database backend ('regular' local usage), we 
should probably be using, ORLite instead of Class::DBI 
(although we have not seen any issues yet).

Please report any bugs or feature requests to C<bug-acme-quotedb at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=ACME-QuoteDB>.  
I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.


=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc ACME::QuoteDB


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=ACME-QuoteDB>

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/ACME-QuoteDB>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/ACME-QuoteDB>

=item * Search CPAN

L<http://search.cpan.org/dist/ACME-QuoteDB/>

=back

=head1 ACKNOWLEDGEMENTS

The construction of this module was guided by:

Perl Best Practices - Conway

Test Driven Development

Object Oriented Programming

Gnu

vim 

Debian Linux

Mac OSX

The collective wisdom and code of The CPAN

this module was created with module-starter

module-starter --module=ACME::QuoteDB \
        --author="David Wright" --mb --email=david_v_wright@yahoo.com

=head1 ERRATA

    Q: Why did you put it in the ACME namespace?
    A: Seemed appropriate. I emailed modules@cpan.org and didn't get a
       different reaction.

    Q: Why did you write this?
    A: At a past company, a team I worked on a project with had a test suite, 
    in which at the completion of successful tests (100%), a 'wisenheimer' 
    success message would be printed. (Like a quote or joke or the like)
    (Interestingly, it added a 'fun' factor to testing, not that one is needed 
    of course ;). It was hard to justify spending company time to find and 
    add decent content to the hand rolled process, this would have helped.

    Q: Don't you have anything better to do, like some non-trivial work?
    A: Yup

    Q: Hey Dood! why are u uzing Class::DBI as your ORM!?  Haven't your heard 
       of L<DBIx::Class>?
    A: Yup, and I'm aware of 'the new hotness' L<Rose::DB>. If you use this 
       module and are unhappy with the ORM, feel free to change it. 
       So far L<Class::DBI> is working for my needs.


=head1 FOOTNOTES

=over 4

=item fortune 

unix application in 'games' (FreeBSD) type 'man fortune' from the command line

=item copyright infringement 

L<http://www.avvo.com/legal-answers/is-it-copyright-trademark-infringement-to-operate--72508.html>

=item wikiquote

interesting reading, wikiquote fair use doc: L<http://en.wikiquote.org/wiki/Wikiquote:Copyrights>

=back

=head1 LICENSE AND COPYRIGHT

Copyright 2009 David Wright, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.


=cut

1; # End of ACME::QuoteDB

 view all matches for this distribution


( run in 2.160 seconds using v1.00-cache-2.02-grep-82fe00e-cpan-503542c4f10 )