Result:
found more than 489 distributions - search limited to the first 2001 files matching your query
( run in 0.932 )
A1z-HTML5-Template
view release on metacpan or search on metacpan
lib/A1z/HTML5/Template.pm view on Meta::CPAN
{
# 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
lib/A1z/HTML5/Template.pm view on Meta::CPAN
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">×</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);
lib/A1z/HTML5/Template.pm view on Meta::CPAN
}
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')
lib/A1z/HTML5/Template.pm view on Meta::CPAN
$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 => '',
@_,
);
lib/A1z/HTML5/Template.pm view on Meta::CPAN
=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.
lib/A1z/HTML5/Template.pm view on Meta::CPAN
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
lib/A1z/HTML5/Template.pm view on Meta::CPAN
);
=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
AAAA-Crypt-DH
view release on metacpan or search on metacpan
inc/Module/Install/Fetch.pm view on Meta::CPAN
#line 1
package Module::Install::Fetch;
use strict;
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '1.17';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
sub get_file {
my ($self, %args) = @_;
my ($scheme, $host, $path, $file) =
$args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) {
$args{url} = $args{ftp_url}
or (warn("LWP support unavailable!\n"), return);
($scheme, $host, $path, $file) =
$args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
}
$|++;
print "Fetching '$file' from $host... ";
unless (eval { require Socket; Socket::inet_aton($host) }) {
warn "'$host' resolve failed!\n";
return;
}
return unless $scheme eq 'ftp' or $scheme eq 'http';
require Cwd;
my $dir = Cwd::getcwd();
chdir $args{local_dir} or return if exists $args{local_dir};
if (eval { require LWP::Simple; 1 }) {
LWP::Simple::mirror($args{url}, $file);
}
elsif (eval { require Net::FTP; 1 }) { eval {
# use Net::FTP to get past firewall
my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600);
$ftp->login("anonymous", 'anonymous@example.com');
$ftp->cwd($path);
$ftp->binary;
$ftp->get($file) or (warn("$!\n"), return);
$ftp->quit;
} }
elsif (my $ftp = $self->can_run('ftp')) { eval {
# no Net::FTP, fallback to ftp.exe
require FileHandle;
my $fh = FileHandle->new;
local $SIG{CHLD} = 'IGNORE';
unless ($fh->open("|$ftp -n")) {
warn "Couldn't open ftp: $!\n";
chdir $dir; return;
}
my @dialog = split(/\n/, <<"END_FTP");
open $host
user anonymous anonymous\@example.com
cd $path
binary
get $file $file
quit
END_FTP
foreach (@dialog) { $fh->print("$_\n") }
$fh->close;
} }
else {
warn "No working 'ftp' program available!\n";
chdir $dir; return;
}
unless (-f $file) {
warn "Fetching failed: $@\n";
chdir $dir; return;
}
return if exists $args{size} and -s $file != $args{size};
system($args{run}) if exists $args{run};
unlink($file) if $args{remove};
print(((!exists $args{check_for} or -e $args{check_for})
? "done!" : "failed! ($!)"), "\n");
chdir $dir; return !$?;
}
1;
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.
ABNF-Grammar
view release on metacpan or search on metacpan
lib/ABNF/Validator.pm view on Meta::CPAN
use base qw(Exporter);
our @EXPORT_OK = qw(Validator);
Readonly my $ARGUMENTS_RULES => "generic_arguments_rule_for_";
Readonly my $CLASS_MAP => {
Choice => \&_choice,
Group => \&_group,
Range => \&_range,
Reference => \&_reference,
Repetition => \&_repetition,
Rule => \&_rule,
String => \&_string,
Literal => \&_literal,
ProseValue => \&_proseValue
};
=pod
=head1 ABNF::Validator->C<new>($grammar)
Creates a new B<ABNF::Validator> object.
$grammar isa B<ABNF::Grammar>.
=cut
method new(ABNF::Grammar $grammar) {
my $class = ref($self) || $self;
$self = { _grammar => $grammar };
bless($self, $class);
$self->_init();
return $self;
}
method _init() {
my $commands = $self->{_grammar}->commands();
$self->{_commandsPattern} = do {
my $pattern = join(" | ", @$commands);
qr/\A (?: $pattern ) \Z/ix;
};
$self->{_rules} = _value([
values($self->{_grammar}->rules()),
values($BASIC_RULES)
]);
$self->{_regexps} = do {
use Regexp::Grammars;
my %res = ();
foreach my $token ( @$commands ) {
# command
my $str = "
#<logfile: /dev/null>
^ <" . _fixRulename($token) . "> \$
$self->{_rules}
";
$res{$token} = qr{$str }ixs;
# arguments
my $value = $self->{_grammar}->rule($token);
my $name = _fixRulename($ARGUMENTS_RULES . $token);
my $rule = {class => "Rule", name => $name};
my $val = (splitRule($value))[-1];
if ( $value->{value} != $val ) {
$rule->{value} = $val;
my $converted = _value($rule);
$res{$name} = qr{
^ <$name> $
$converted
$self->{_rules}
}xis;
}
}
\%res;
};
}
func _value($val, $dent = 0) {
if ( UNIVERSAL::isa($val, 'ARRAY') ) {
return join('', map { _value($_ , $dent) } @$val);
} elsif ( UNIVERSAL::isa($val, 'HASH') && exists($CLASS_MAP->{ $val->{class} }) ) {
return $CLASS_MAP->{ $val->{class} }->($val, $dent);
} else {
croak "Unknown substance " . Dumper($val);
}
}
func _choice($val, $dent) {
return "(?: " . join(' | ', map { _value($_ , $dent + 1) } @{$val->{value}}) . ")";
}
func _group($val, $dent) {
return '(?: ' . _value($val->{value}, $dent + 1) . ' )';
}
func _reference($val, $dent) {
return "<" . _fixRulename($val->{name}) . ">";
}
func _repetition($val, $dent) {
no warnings 'uninitialized';
my %maxMin = (
# max min
"1 0" => '?',
AC-DC
view release on metacpan or search on metacpan
lib/AC/DC/Debug.pm view on Meta::CPAN
# -*- perl -*-
# Copyright (c) 2009 AdCopy
# Author: Jeff Weisberg
# Created: 2009-Mar-27 11:40 (EDT)
# Function: debugging + log msgs
#
# $Id$
package AC::DC::Debug;
use AC::Daemon;
use strict;
my $config;
my $debugall;
sub init {
shift;
$debugall = shift;
$config = shift;
}
sub _tagged_debug {
my $tag = shift;
my $msg = shift;
if( $config && $config->{config} ){
return unless $config->{config}{debug}{$tag} || $config->{config}{debug}{all} || $debugall;
}else{
return unless $debugall;
}
debugmsg( "$tag - $msg" );
}
sub import {
my $class = shift;
my $tag = shift; # use AC::DC::Debug 'tag';
my $caller = caller;
no strict;
if( $tag ){
# export a curried debug (with the specified tag) to the caller
*{$caller . '::debug'} = sub { _tagged_debug($tag, @_) };
}
for my $f qw(verbose problem fatal){
no strict;
*{$caller . '::' . $f} = $class->can($f);
}
}
1;
AC-MrGamoo
view release on metacpan or search on metacpan
lib/AC/MrGamoo.pm view on Meta::CPAN
AC::MrGamoo - Map/Reduce Framework
=head1 SYNOPSIS
use AC::MrGamoo::D;
use strict;
my $m = AC::MrGamoo::D->new( );
$m->daemon( $configfile, {
argv => \@ARGV,
foreground => $OPT{f},
debugall => $OPT{d},
port => $OPT{p},
} );
exit;
=head1 CONFIG FILE
various parameters need to be specified in a config file.
if you modify the file, it will be reloaded automagically.
=over 4
=item port
specify the TCP port to use
port 3504
=item environment
specify the environment or realm to run in, so you can run multiple
independent map/reduce networks, such as production, staging, and dev.
environment prod
=item allow
specify networks allowed to connect.
allow 127.0.0.1
allow 192.168.10.0/24
=item seedpeer
specify initial peers to contact when starting. the author generally
specifies 2 on the east coast, and 2 on the west coast.
seedpeer 192.168.10.11:3503
seedpeer 192.168.10.12:3503
=item secret
specify a secret key used to encrypt data transfered between
systems in different datacenters.
secret squeamish-ossifrage
=item syslog
specify a syslog facility for log messages.
syslog local5
=item basedir
local directory to store files
basedir /home/data
=item debug
enable debugging for a particular section
debug job
=back
=head1 BUGS
Too many to list here.
=head1 SEE ALSO
AC::MrGamoo::Client
=head1 AUTHOR
Jeff Weisberg - http://www.solvemedia.com/
=cut
1;
AC-Yenta
view release on metacpan or search on metacpan
lib/AC/Yenta.pm view on Meta::CPAN
our $VERSION = 1.1;
=head1 NAME
AC::Yenta - eventually-consistent distributed key/value data store. et al.
=head1 SYNOPSIS
use AC::Yenta::D;
use strict;
my $y = AC::Yenta::D->new( );
$y->daemon( $configfile, {
argv => \@ARGV,
foreground => $OPT{f},
debugall => $OPT{d},
port => $OPT{p},
} );
exit;
=head1 USAGE
Copy + Paste from the example code into your own code.
Copy + Paste from the example config into your own config.
Send in bug report.
=head1 YIDDISH-ENGLISH GLOSSARY
Kibitz - Gossip. Casual information exchange with ones peers.
Yenta - 1. An old woman who kibitzes with other yentas.
2. Software which kibitzes with other yentas.
=head1 DESCRIPTION
=head2 Peers
All of the running yentas are peers. There is no master server.
New nodes can be added or removed on the fly with no configuration.
=head2 Kibitzing
Each yenta kibitzes (gossips) with the other yentas in the network
to exchange status information, distribute key-value data, and
detect and correct inconsistent data.
=head2 Eventual Consistency
Key-value data is versioned with timestamps. By default, newest wins.
Maps can be configured to keep and return multiple versions and client
code can use other conflict resolution mechanisms.
Lost, missing or otherwise inconsistent data is detected
by kibitzing merkle tree hash values.
=head2 Topological awareness
Yentas can take network topology into account when tranferring
data around to minimize long-distance transfers. You will need to
write a custom C<MySelf> class with a C<my_datacenter> function.
=head2 Multiple Network Interfaces / NAT
Yentas can take advantage of multiple network interfaces with
different IP addresses (eg. a private internal network + a public network),
or multiple addresses (eg. a private addresses and a public address)
and various NAT configurations.
You will need to write a custom C<MySelf> class and C<my_network_info>
function.
=head2 Network Information
By default, yentas obtain their primary IP address by calling
C<gethostbyname( hostname() )>. If this either does not work on your
systems, or isn't the value you want to use,
you will need to write a custom C<MySelf> class and C<my_network_info>
function.
=head1 CONFIG FILE
various parameters need to be specified in a config file.
if you modify the file, it will be reloaded automagically.
=over 4
=item port
specify the TCP port to use
port 3503
=item environment
specify the environment or realm to run in, so you can run multiple
independent yenta networks, such as production, staging, and dev.
environment prod
=item allow
specify networks allowed to connect.
allow 127.0.0.1
allow 192.168.10.0/24
=item seedpeer
specify initial peers to contact when starting. the author generally
specifies 2 on the east coast, and 2 on the west coast.
seedpeer 192.168.10.11:3503
seedpeer 192.168.10.12:3503
=item secret
specify a secret key used to encrypt data transfered between
yentas in different datacenters.
secret squeamish-ossifrage
=item syslog
specify a syslog facility for log messages.
syslog local5
=item debug
enable debugging for a particular section
debug map
=item map
configure a map (a collection of key-value data). you do not need
to configure the same set of maps on all servers. maps should be
configured similarly on all servers that they are on.
map users {
backend bdb
dbfile /home/acdata/users.ydb
history 4
}
=back
=head1 BUGS
Too many to list here.
=head1 SEE ALSO
AC::Yenta::Client
Amazon Dynamo - http://www.allthingsdistributed.com/2007/10/amazons_dynamo.html
=head1 AUTHOR
Jeff Weisberg - http://www.solvemedia.com/
=cut
1;
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 );
ACME-Dzil-Test-daemon
view release on metacpan or search on metacpan
Version change log for ACME-Dzil-Test-daemon
0.001 2021-12-16 19:34:59 GMT
- The first thing you changed!
- Test entry
ACME-Dzil-Test-daemon2
view release on metacpan or search on metacpan
Version change log for ACME-Dzil-Test-daemon2
0.001 2021-12-16 19:51:37 GMT
- The first thing you changed!
ACME-MyFirstModule-SETHS
view release on metacpan or search on metacpan
lib/ACME/MyFirstModule/SETHS.pm view on Meta::CPAN
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
ACME-THEDANIEL-Utils
view release on metacpan or search on metacpan
lib/ACME/THEDANIEL/Utils.pm view on Meta::CPAN
=head1 BUGS
Please report any bugs or feature requests to C<bug-acme-thedaniel-utils at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=ACME-THEDANIEL-Utils>. 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::THEDANIEL::Utils
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-THEDANIEL-Utils>
=item * AnnoCPAN: Annotated CPAN documentation
L<http://annocpan.org/dist/ACME-THEDANIEL-Utils>
=item * CPAN Ratings
L<http://cpanratings.perl.org/d/ACME-THEDANIEL-Utils>
=item * Search CPAN
L<http://search.cpan.org/dist/ACME-THEDANIEL-Utils/>
=back
=head1 ACKNOWLEDGEMENTS
Intermediate Perl, 2nd Edition.
=head1 LICENSE AND COPYRIGHT
Copyright 2017 Daniel jones.
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::THEDANIEL::Utils
ADAMK-Release
view release on metacpan or search on metacpan
inc/Module/Install/Fetch.pm view on Meta::CPAN
#line 1
package Module::Install::Fetch;
use strict;
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '1.06';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
sub get_file {
my ($self, %args) = @_;
my ($scheme, $host, $path, $file) =
$args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) {
$args{url} = $args{ftp_url}
or (warn("LWP support unavailable!\n"), return);
($scheme, $host, $path, $file) =
$args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
}
$|++;
print "Fetching '$file' from $host... ";
unless (eval { require Socket; Socket::inet_aton($host) }) {
warn "'$host' resolve failed!\n";
return;
}
return unless $scheme eq 'ftp' or $scheme eq 'http';
require Cwd;
my $dir = Cwd::getcwd();
chdir $args{local_dir} or return if exists $args{local_dir};
if (eval { require LWP::Simple; 1 }) {
LWP::Simple::mirror($args{url}, $file);
}
elsif (eval { require Net::FTP; 1 }) { eval {
# use Net::FTP to get past firewall
my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600);
$ftp->login("anonymous", 'anonymous@example.com');
$ftp->cwd($path);
$ftp->binary;
$ftp->get($file) or (warn("$!\n"), return);
$ftp->quit;
} }
elsif (my $ftp = $self->can_run('ftp')) { eval {
# no Net::FTP, fallback to ftp.exe
require FileHandle;
my $fh = FileHandle->new;
local $SIG{CHLD} = 'IGNORE';
unless ($fh->open("|$ftp -n")) {
warn "Couldn't open ftp: $!\n";
chdir $dir; return;
}
my @dialog = split(/\n/, <<"END_FTP");
open $host
user anonymous anonymous\@example.com
cd $path
binary
get $file $file
quit
END_FTP
foreach (@dialog) { $fh->print("$_\n") }
$fh->close;
} }
else {
warn "No working 'ftp' program available!\n";
chdir $dir; return;
}
unless (-f $file) {
warn "Fetching failed: $@\n";
chdir $dir; return;
}
return if exists $args{size} and -s $file != $args{size};
system($args{run}) if exists $args{run};
unlink($file) if $args{remove};
print(((!exists $args{check_for} or -e $args{check_for})
? "done!" : "failed! ($!)"), "\n");
chdir $dir; return !$?;
}
1;
AES128
view release on metacpan or search on metacpan
for changes, use:
perl ppport.h --nochanges
You can specify a different C<diff> program or options, using
the C<--diff> option:
perl ppport.h --diff='diff -C 10'
This would output context diffs with 10 lines of context.
If you want to create patched copies of your files instead, use:
perl ppport.h --copy=.new
To display portability information for the C<newSVpvn> function,
use:
perl ppport.h --api-info=newSVpvn
Since the argument to C<--api-info> can be a regular expression,
you can use
perl ppport.h --api-info=/_nomg$/
to display portability information for all C<_nomg> functions or
perl ppport.h --api-info=/./
to display information for all known API elements.
=head1 BUGS
If this version of F<ppport.h> is causing failure during
the compilation of this module, please check if newer versions
of either this module or C<Devel::PPPort> are available on CPAN
before sending a bug report.
If F<ppport.h> was generated using the latest version of
C<Devel::PPPort> and is causing failure of this module, please
file a bug report here: L<https://github.com/mhx/Devel-PPPort/issues/>
Please include the following information:
=over 4
=item 1.
The complete output from running "perl -V"
=item 2.
This file.
=item 3.
The name and version of the module you were trying to build.
=item 4.
A full log of the build that failed.
=item 5.
Any other information that you think could be relevant.
=back
For the latest version of this code, please get the C<Devel::PPPort>
module from CPAN.
=head1 COPYRIGHT
Version 3.x, Copyright (c) 2004-2013, Marcus Holland-Moritz.
Version 2.x, Copyright (C) 2001, Paul Marquess.
Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=head1 SEE ALSO
See L<Devel::PPPort>.
=cut
use strict;
# Disable broken TRIE-optimization
BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if $] >= 5.009004 && $] <= 5.009005 }
my $VERSION = 3.35;
my %opt = (
quiet => 0,
diag => 1,
hints => 1,
changes => 1,
cplusplus => 0,
filter => 1,
strip => 0,
version => 0,
);
my($ppport) = $0 =~ /([\w.]+)$/;
my $LF = '(?:\r\n|[\r\n])'; # line feed
my $HS = "[ \t]"; # horizontal whitespace
# Never use C comments in this file!
my $ccs = '/'.'*';
my $cce = '*'.'/';
my $rccs = quotemeta $ccs;
my $rcce = quotemeta $cce;
eval {
require Getopt::Long;
Getopt::Long::GetOptions(\%opt, qw(
help quiet diag! filter! hints! changes! cplusplus strip version
patch=s copy=s diff=s compat-version=s
magic_getarylen|||
magic_getdebugvar|||
magic_getdefelem|||
magic_getnkeys|||
magic_getpack|||
magic_getpos|||
magic_getsig|||
magic_getsubstr|||
magic_gettaint|||
magic_getuvar|||
magic_getvec|||
magic_get|||
magic_killbackrefs|||
magic_methcall1|||
magic_methcall|||v
magic_methpack|||
magic_nextpack|||
magic_regdata_cnt|||
magic_regdatum_get|||
magic_regdatum_set|||
magic_scalarpack|||
magic_set_all_env|||
magic_setarylen|||
magic_setcollxfrm|||
magic_setdbline|||
magic_setdebugvar|||
magic_setdefelem|||
magic_setenv|||
magic_sethint|||
magic_setisa|||
magic_setlvref|||
magic_setmglob|||
magic_setnkeys|||
magic_setpack|||
magic_setpos|||
magic_setregexp|||
magic_setsig|||
magic_setsubstr|||
magic_settaint|||
magic_setutf8|||
magic_setuvar|||
magic_setvec|||
magic_set|||
magic_sizepack|||
magic_wipepack|||
make_matcher|||
make_trie|||
malloc_good_size|||n
malloced_size|||n
malloc||5.007002|n
markstack_grow||5.021001|
matcher_matches_sv|||
maybe_multimagic_gv|||
mayberelocate|||
measure_struct|||
memEQs|5.009005||p
memEQ|5.004000||p
memNEs|5.009005||p
memNE|5.004000||p
mem_collxfrm|||
mem_log_alloc|||n
mem_log_common|||n
mem_log_free|||n
mem_log_realloc|||n
mess_alloc|||
mess_nocontext|||vn
mess_sv||5.013001|
mess||5.006000|v
mfree||5.007002|n
mg_clear|||
mg_copy|||
mg_dup|||
mg_find_mglob|||
mg_findext|5.013008||pn
mg_find|||n
mg_free_type||5.013006|
mg_free|||
mg_get|||
mg_length||5.005000|
mg_localize|||
mg_magical|||n
mg_set|||
mg_size||5.005000|
mini_mktime||5.007002|n
minus_v|||
missingterm|||
mode_from_discipline|||
modkids|||
more_bodies|||
more_sv|||
moreswitches|||
move_proto_attr|||
mro_clean_isarev|||
mro_gather_and_rename|||
mro_get_from_name||5.010001|
mro_get_linear_isa_dfs|||
mro_get_linear_isa||5.009005|
mro_get_private_data||5.010001|
mro_isa_changed_in|||
mro_meta_dup|||
mro_meta_init|||
mro_method_changed_in||5.009005|
mro_package_moved|||
mro_register||5.010001|
mro_set_mro||5.010001|
mro_set_private_data||5.010001|
mul128|||
mulexp10|||n
multideref_stringify|||
my_atof2||5.007002|
my_atof||5.006000|
my_attrs|||
my_bcopy||5.004050|n
my_bytes_to_utf8|||n
my_bzero|||n
my_chsize|||
my_clearenv|||
my_cxt_index|||
my_cxt_init|||
my_dirfd||5.009005|n
my_exit_jump|||
my_exit|||
my_failure_exit||5.004000|
my_fflush_all||5.006000|
newLOGOP|||
newLOOPEX|||
newLOOPOP|||
newMETHOP_internal|||
newMETHOP_named||5.021005|
newMETHOP||5.021005|
newMYSUB||5.017004|
newNULLLIST|||
newOP|||
newPADNAMELIST||5.021007|n
newPADNAMEouter||5.021007|n
newPADNAMEpvn||5.021007|n
newPADOP|||
newPMOP|||
newPROG|||
newPVOP|||
newRANGE|||
newRV_inc|5.004000||p
newRV_noinc|5.004000||p
newRV|||
newSLICEOP|||
newSTATEOP|||
newSTUB|||
newSUB|||
newSVOP|||
newSVREF|||
newSV_type|5.009005||p
newSVavdefelem|||
newSVhek||5.009003|
newSViv|||
newSVnv|||
newSVpadname||5.017004|
newSVpv_share||5.013006|
newSVpvf_nocontext|||vn
newSVpvf||5.004000|v
newSVpvn_flags|5.010001||p
newSVpvn_share|5.007001||p
newSVpvn_utf8|5.010001||p
newSVpvn|5.004050||p
newSVpvs_flags|5.010001||p
newSVpvs_share|5.009003||p
newSVpvs|5.009003||p
newSVpv|||
newSVrv|||
newSVsv|||
newSVuv|5.006000||p
newSV|||
newUNOP_AUX||5.021007|
newUNOP|||
newWHENOP||5.009003|
newWHILEOP||5.013007|
newXS_deffile|||
newXS_flags||5.009004|
newXS_len_flags|||
newXSproto||5.006000|
newXS||5.006000|
new_collate||5.006000|
new_constant|||
new_ctype||5.006000|
new_he|||
new_logop|||
new_numeric||5.006000|
new_stackinfo||5.005000|
new_version||5.009000|
new_warnings_bitfield|||
next_symbol|||
nextargv|||
nextchar|||
ninstr|||n
no_bareword_allowed|||
no_fh_allowed|||
no_op|||
noperl_die|||vn
not_a_number|||
not_incrementable|||
nothreadhook||5.008000|
nuke_stacks|||
num_overflow|||n
oopsAV|||
oopsHV|||
op_append_elem||5.013006|
op_append_list||5.013006|
op_clear|||
op_contextualize||5.013006|
op_convert_list||5.021006|
op_dump||5.006000|
op_free|||
op_integerize|||
op_linklist||5.013006|
op_lvalue_flags|||
op_lvalue||5.013007|
op_null||5.007002|
op_parent|||n
op_prepend_elem||5.013006|
op_refcnt_dec|||
op_refcnt_inc|||
op_refcnt_lock||5.009002|
op_refcnt_unlock||5.009002|
op_relocate_sv|||
op_scope||5.013007|
op_sibling_splice||5.021002|n
op_std_init|||
op_unscope|||
open_script|||
openn_cleanup|||
openn_setup|||
opmethod_stash|||
opslab_force_free|||
opslab_free_nopad|||
opslab_free|||
output_or_return_posix_warnings|||
pMY_CXT_|5.007003||p
pMY_CXT|5.007003||p
pTHX_|5.006000||p
pTHX|5.006000||p
packWARN|5.007003||p
pack_cat||5.007003|
pack_rec|||
package_version|||
package|||
packlist||5.008001|
upg_version||5.009005|
usage|||
utf16_textfilter|||
utf16_to_utf8_reversed||5.006001|
utf16_to_utf8||5.006001|
utf8_distance||5.006000|
utf8_hop||5.006000|n
utf8_length||5.007001|
utf8_mg_len_cache_update|||
utf8_mg_pos_cache_update|||
utf8_to_bytes||5.006001|
utf8_to_uvchr_buf||5.015009|
utf8_to_uvchr||5.007001|
utf8_to_uvuni_buf||5.015009|
utf8_to_uvuni||5.007001|
utf8n_to_uvchr||5.007001|
utf8n_to_uvuni||5.007001|
utilize|||
uvchr_to_utf8_flags||5.007003|
uvchr_to_utf8||5.007001|
uvoffuni_to_utf8_flags||5.019004|
uvuni_to_utf8_flags||5.007003|
uvuni_to_utf8||5.007001|
valid_utf8_to_uvchr||5.015009|
valid_utf8_to_uvuni||5.015009|
validate_proto|||
validate_suid|||
varname|||
vcmp||5.009000|
vcroak||5.006000|
vdeb||5.007003|
vform||5.006000|
visit|||
vivify_defelem|||
vivify_ref|||
vload_module|5.006000||p
vmess||5.006000|
vnewSVpvf|5.006000|5.004000|p
vnormal||5.009002|
vnumify||5.009000|
vstringify||5.009000|
vverify||5.009003|
vwarner||5.006000|
vwarn||5.006000|
wait4pid|||
warn_nocontext|||vn
warn_sv||5.013001|
warner_nocontext|||vn
warner|5.006000|5.004000|pv
warn|||v
was_lvalue_sub|||
watch|||
whichsig_pvn||5.015004|
whichsig_pv||5.015004|
whichsig_sv||5.015004|
whichsig|||
win32_croak_not_implemented|||n
with_queued_errors|||
wrap_op_checker||5.015008|
write_to_stderr|||
xs_boot_epilog|||
xs_handshake|||vn
xs_version_bootcheck|||
yyerror_pvn|||
yyerror_pv|||
yyerror|||
yylex|||
yyparse|||
yyunlex|||
yywarn|||
);
if (exists $opt{'list-unsupported'}) {
my $f;
for $f (sort { lc $a cmp lc $b } keys %API) {
next unless $API{$f}{todo};
print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n";
}
exit 0;
}
# Scan for possible replacement candidates
my(%replace, %need, %hints, %warnings, %depends);
my $replace = 0;
my($hint, $define, $function);
sub find_api
{
my $code = shift;
$code =~ s{
/ (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*)
| "[^"\\]*(?:\\.[^"\\]*)*"
| '[^'\\]*(?:\\.[^'\\]*)*' }{}egsx;
grep { exists $API{$_} } $code =~ /(\w+)/mg;
}
while (<DATA>) {
if ($hint) {
my $h = $hint->[0] eq 'Hint' ? \%hints : \%warnings;
if (m{^\s*\*\s(.*?)\s*$}) {
for (@{$hint->[1]}) {
$h->{$_} ||= ''; # suppress warning with older perls
$h->{$_} .= "$1\n";
}
}
else { undef $hint }
}
$hint = [$1, [split /,?\s+/, $2]]
if m{^\s*$rccs\s+(Hint|Warning):\s+(\w+(?:,?\s+\w+)*)\s*$};
if ($define) {
if ($define->[1] =~ /\\$/) {
$define->[1] .= $_;
}
else {
if (exists $API{$define->[0]} && $define->[1] !~ /^DPPP_\(/) {
my @n = find_api($define->[1]);
push @{$depends{$define->[0]}}, @n if @n
}
AFS-Command
view release on metacpan or search on metacpan
lib/AFS/Command/BOS.pm view on Meta::CPAN
use AFS::Command::Base;
use AFS::Object;
use AFS::Object::BosServer;
use AFS::Object::Instance;
our @ISA = qw(AFS::Command::Base);
our $VERSION = '1.99';
sub getdate {
my $self = shift;
my (%args) = @_;
my $result = AFS::Object::BosServer->new();
$self->{operation} = "getdate";
my $directory = $args{dir} || '/usr/afs/bin';
return unless $self->_parse_arguments(%args);
return unless $self->_save_stderr();
my $errors = 0;
$errors++ unless $self->_exec_cmds();
while ( defined($_ = $self->{handle}->getline()) ) {
chomp;
next unless m:File $directory/(\S+) dated ([^,]+),:;
my $file = AFS::Object->new
(
file => $1,
date => $2,
);
if ( /\.BAK dated ([^,]+),/ ) {
$file->_setAttribute( bak => $1 );
}
if ( /\.OLD dated ([^,\.]+)/ ) {
$file->_setAttribute( old => $1 );
}
$result->_addFile($file);
}
$errors++ unless $self->_reap_cmds();
$errors++ unless $self->_restore_stderr();
return if $errors;
return $result;
}
sub getlog {
my $self = shift;
my (%args) = @_;
my $result = AFS::Object::BosServer->new();
$self->{operation} = "getlog";
my $redirect = undef;
my $redirectname = undef;
if ( $args{redirect} ) {
$redirectname = delete $args{redirect};
$redirect = IO::File->new(">$redirectname") || do {
$self->_Carp("Unable to write to $redirectname: $ERRNO");
return;
};
}
return unless $self->_parse_arguments(%args);
return unless $self->_save_stderr();
my $errors = 0;
$errors++ unless $self->_exec_cmds();
my $log = "";
while ( defined($_ = $self->{handle}->getline()) ) {
next if /^Fetching log file/;
if ( $redirect ) {
$redirect->print($_);
} else {
$log .= $_;
}
}
if ( $redirect ) {
$redirect->close()|| do {
$self->_Carp("Unable to close $redirectname: $ERRNO");
$errors++
};
$result->_setAttribute( log => $redirectname );
} else {
$result->_setAttribute( log => $log );
}
$errors++ unless $self->_reap_cmds();
$errors++ unless $self->_restore_stderr();
return if $errors;
return $result;
}
sub getrestart {
my $self = shift;
my (%args) = @_;
my $result = AFS::Object::BosServer->new();
$self->{operation} = "getrestart";
return unless $self->_parse_arguments(%args);
return unless $self->_save_stderr();
my $errors = 0;
$errors++ unless $self->_exec_cmds();
while ( defined($_ = $self->{handle}->getline()) ) {
if ( /restarts at (.*)/ || /restarts (never)/ ) {
$result->_setAttribute( restart => $1 );
} elsif ( /binaries at (.*)/ || /binaries (never)/ ) {
$result->_setAttribute( binaries => $1 );
}
}
$errors++ unless $self->_reap_cmds();
$errors++ unless $self->_restore_stderr();
return if $errors;
return $result;
}
sub listhosts {
my $self = shift;
my (%args) = @_;
my $result = AFS::Object::BosServer->new();
$self->{operation} = "listhosts";
return unless $self->_parse_arguments(%args);
return unless $self->_save_stderr();
my $errors = 0;
AFS-Monitor
view release on metacpan or search on metacpan
examples/xstat_cm_test view on Meta::CPAN
printf "\t%10d afs_MemCacheStoreProc\n", $data->{afs_MemCacheStoreProc};
printf "\t%10d afs_GetNfsClientPag\n", $data->{afs_GetNfsClientPag};
printf "\t%10d afs_FindNfsClientPag\n", $data->{afs_FindNfsClientPag};
printf "\t%10d afs_PutNfsClientPag\n", $data->{afs_PutNfsClientPag};
printf "\t%10d afs_nfsclient_reqhandler\n", $data->{afs_nfsclient_reqhandler};
printf "\t%10d afs_nfsclient_GC\n", $data->{afs_nfsclient_GC};
printf "\t%10d afs_nfsclient_hold\n", $data->{afs_nfsclient_hold};
printf "\t%10d afs_nfsclient_stats\n", $data->{afs_nfsclient_stats};
printf "\t%10d afs_nfsclient_sysname\n", $data->{afs_nfsclient_sysname};
printf "\t%10d afs_rfs_dispatch\n", $data->{afs_rfs_dispatch};
printf "\t%10d afs_nfs2afscall\n", $data->{Nfs2AfsCall};
printf "\t%10d afs_sun_xuntext\n", $data->{afs_sun_xuntext};
printf "\t%10d osi_Active\n", $data->{osi_Active};
printf "\t%10d osi_FlushPages\n", $data->{osi_FlushPages};
printf "\t%10d osi_FlushText\n", $data->{osi_FlushText};
printf "\t%10d osi_CallProc\n", $data->{osi_CallProc};
printf "\t%10d osi_CancelProc\n", $data->{osi_CancelProc};
printf "\t%10d osi_Invisible\n", $data->{osi_Invisible};
printf "\t%10d osi_Time\n", $data->{osi_Time};
printf "\t%10d osi_Alloc\n", $data->{osi_Alloc};
printf "\t%10d osi_SetTime\n", $data->{osi_SetTime};
printf "\t%10d osi_Dump\n", $data->{osi_Dump};
printf "\t%10d osi_Free\n", $data->{osi_Free};
printf "\t%10d osi_UFSOpen\n", $data->{osi_UFSOpen};
printf "\t%10d osi_Close\n", $data->{osi_Close};
printf "\t%10d osi_Stat\n", $data->{osi_Stat};
printf "\t%10d osi_Truncate\n", $data->{osi_Truncate};
printf "\t%10d osi_Read\n", $data->{osi_Read};
printf "\t%10d osi_Write\n", $data->{osi_Write};
printf "\t%10d osi_MapStrategy\n", $data->{osi_MapStrategy};
printf "\t%10d osi_AllocLargeSpace\n", $data->{osi_AllocLargeSpace};
printf "\t%10d osi_FreeLargeSpace\n", $data->{osi_FreeLargeSpace};
printf "\t%10d osi_AllocSmallSpace\n", $data->{osi_AllocSmallSpace};
printf "\t%10d osi_FreeSmallSpace\n", $data->{osi_FreeSmallSpace};
printf "\t%10d osi_CloseToTheEdge\n", $data->{osi_CloseToTheEdge};
printf "\t%10d osi_xgreedy\n", $data->{osi_xgreedy};
printf "\t%10d osi_FreeSocket\n", $data->{osi_FreeSocket};
printf "\t%10d osi_NewSocket\n", $data->{osi_NewSocket};
printf "\t%10d osi_NetSend\n", $data->{osi_NetSend};
printf "\t%10d WaitHack\n", $data->{WaitHack};
printf "\t%10d osi_CancelWait\n", $data->{osi_CancelWait};
printf "\t%10d osi_Wakeup\n", $data->{osi_Wakeup};
printf "\t%10d osi_Wait\n", $data->{osi_Wait};
printf "\t%10d dirp_Read\n", $data->{dirp_Read};
printf "\t%10d dirp_Cpy\n", $data->{dirp_Cpy};
printf "\t%10d dirp_Eq\n", $data->{dirp_Eq};
printf "\t%10d dirp_Write\n", $data->{dirp_Write};
printf "\t%10d dirp_Zap\n", $data->{dirp_Zap};
printf "\t%10d afs_ioctl\n", $data->{afs_ioctl};
printf "\t%10d handleIoctl\n", $data->{HandleIoctl};
printf "\t%10d afs_xioctl\n", $data->{afs_xioctl};
printf "\t%10d afs_pioctl\n", $data->{afs_pioctl};
printf "\t%10d HandlePioctl\n", $data->{HandlePioctl};
printf "\t%10d PGetVolumeStatus\n", $data->{PGetVolumeStatus};
printf "\t%10d PSetVolumeStatus\n", $data->{PSetVolumeStatus};
printf "\t%10d PFlush\n", $data->{PFlush};
printf "\t%10d PFlushVolumeData\n", $data->{PFlushVolumeData};
printf "\t%10d PNewStatMount\n", $data->{PNewStatMount};
printf "\t%10d PGetTokens\n", $data->{PGetTokens};
printf "\t%10d PSetTokens\n", $data->{PSetTokens};
printf "\t%10d PUnlog\n", $data->{PUnlog};
printf "\t%10d PCheckServers\n", $data->{PCheckServers};
printf "\t%10d PCheckAuth\n", $data->{PCheckAuth};
printf "\t%10d PCheckVolNames\n", $data->{PCheckVolNames};
printf "\t%10d PFindVolume\n", $data->{PFindVolume};
printf "\t%10d Prefetch\n", $data->{Prefetch};
printf "\t%10d PGetCacheSize\n", $data->{PGetCacheSize};
printf "\t%10d PSetCacheSize\n", $data->{PSetCacheSize};
printf "\t%10d PSetSysName\n", $data->{PSetSysName};
printf "\t%10d PExportAfs\n", $data->{PExportAfs};
printf "\t%10d HandleClientContext\n", $data->{HandleClientContext};
printf "\t%10d PViceAccess\n", $data->{PViceAccess};
printf "\t%10d PRemoveCallBack\n", $data->{PRemoveCallBack};
printf "\t%10d PRemoveMount\n", $data->{PRemoveMount};
printf "\t%10d PSetVolumeStatus\n", $data->{PSetVolumeStatus};
printf "\t%10d PListCells\n", $data->{PListCells};
printf "\t%10d PNewCell\n", $data->{PNewCell};
printf "\t%10d PGetUserCell\n", $data->{PGetUserCell};
printf "\t%10d PGetCellStatus\n", $data->{PGetCellStatus};
printf "\t%10d PSetCellStatus\n", $data->{PSetCellStatus};
printf "\t%10d PVenusLogging\n", $data->{PVenusLogging};
printf "\t%10d PGetAcl\n", $data->{PGetAcl};
printf "\t%10d PGetFID\n", $data->{PGetFID};
printf "\t%10d PSetAcl\n", $data->{PSetAcl};
printf "\t%10d PGetFileCell\n", $data->{PGetFileCell};
printf "\t%10d PGetWSCell\n", $data->{PGetWSCell};
printf "\t%10d PGetSPrefs\n", $data->{PGetSPrefs};
printf "\t%10d PSetSPrefs\n", $data->{PSetSPrefs};
printf "\t%10d afs_ResetAccessCache\n", $data->{afs_ResetAccessCache};
printf "\t%10d afs_FindUser\n", $data->{afs_FindUser};
printf "\t%10d afs_GetUser\n", $data->{afs_GetUser};
printf "\t%10d afs_GCUserData\n", $data->{afs_GCUserData};
printf "\t%10d afs_PutUser\n", $data->{afs_PutUser};
printf "\t%10d afs_SetPrimary\n", $data->{afs_SetPrimary};
printf "\t%10d afs_ResetUserConns\n", $data->{afs_ResetUserConns};
printf "\t%10d afs_RemoveUserConns\n", $data->{RemoveUserConns};
printf "\t%10d afs_ResourceInit\n", $data->{afs_ResourceInit};
printf "\t%10d afs_GetCell\n", $data->{afs_GetCell};
printf "\t%10d afs_GetCellByIndex\n", $data->{afs_GetCellByIndex};
printf "\t%10d afs_GetCellByName\n", $data->{afs_GetCellByName};
if (exists $data->{afs_GetRealCellByIndex}) {
printf "\t%10d afs_GetRealCellByIndex\n", $data->{afs_GetRealCellByIndex};
}
printf "\t%10d afs_NewCell\n", $data->{afs_NewCell};
printf "\t%10d CheckVLDB\n", $data->{CheckVLDB};
printf "\t%10d afs_GetVolume\n", $data->{afs_GetVolume};
printf "\t%10d afs_PutVolume\n", $data->{afs_PutVolume};
printf "\t%10d afs_GetVolumeByName\n", $data->{afs_GetVolumeByName};
printf "\t%10d afs_random\n", $data->{afs_random};
printf "\t%10d InstallVolumeEntry\n", $data->{InstallVolumeEntry};
printf "\t%10d InstallVolumeInfo\n", $data->{InstallVolumeInfo};
printf "\t%10d afs_ResetVolumeInfo\n", $data->{afs_ResetVolumeInfo};
printf "\t%10d afs_FindServer\n", $data->{afs_FindServer};
printf "\t%10d afs_GetServer\n", $data->{afs_GetServer};
printf "\t%10d afs_SortServers\n", $data->{afs_SortServers};
printf "\t%10d afs_CheckServers\n", $data->{afs_CheckServers};
printf "\t%10d ServerDown\n", $data->{ServerDown};
printf "\t%10d afs_Conn\n", $data->{afs_Conn};
printf "\t%10d afs_PutConn\n", $data->{afs_PutConn};
printf "\t%10d afs_ConnByHost\n", $data->{afs_ConnByHost};
printf "\t%10d afs_ConnByMHosts\n", $data->{afs_ConnByMHosts};
AFS-PAG
view release on metacpan or search on metacpan
lib/AFS/PAG.pm view on Meta::CPAN
# Perl bindings for the PAG functions in libkafs.
#
# This is the Perl boostrap file for the AFS::PAG module, nearly all of which
# is implemented in XS. For the actual source, see PAG.xs. This file
# contains the bootstrap and export code and the documentation.
#
# Written by Russ Allbery <rra@cpan.org>
# Copyright 2013
# The Board of Trustees of the Leland Stanford Junior University
#
# Permission is hereby granted, free of charge, to any person obtaining a
# copy of this software and associated documentation files (the "Software"),
# to deal in the Software without restriction, including without limitation
# the rights to use, copy, modify, merge, publish, distribute, sublicense,
# and/or sell copies of the Software, and to permit persons to whom the
# Software is furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
# THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
# DEALINGS IN THE SOFTWARE.
package AFS::PAG;
use 5.008;
use strict;
use warnings;
use base qw(DynaLoader);
use Exporter qw(import);
our (@EXPORT_OK, $VERSION);
# Set all import-related variables in a BEGIN block for robustness.
BEGIN {
@EXPORT_OK = qw(hasafs haspag setpag unlog);
$VERSION = '1.02';
}
# Load the binary module.
bootstrap AFS::PAG $VERSION;
1;
__END__
=for stopwords
Allbery AFS PAG libkafs libkopenafs Kerberos aklog UID kdestroy
=head1 NAME
AFS::PAG - Perl bindings for AFS PAG manipulation
=head1 SYNOPSIS
use AFS::PAG qw(hasafs setpag unlog);
if (hasafs()) {
setpag();
system('aklog') == 0
or die "cannot get tokens\n";
do_afs_things();
unlog();
}
=head1 DESCRIPTION
AFS is a distributed file system allowing cross-platform sharing of files
among multiple computers. It associates client credentials (called AFS
tokens) with a Process Authentication Group, or PAG. AFS::PAG makes
available in Perl the PAG manipulation functions provided by the libkafs
or libkopenafs libraries.
With the functions provided by this module, a Perl program can detect
whether AFS is available on the local system (hasafs()) and whether it is
currently running inside a PAG (haspag()). It can also create a new PAG
and put the current process in it (setpag()) and remove any AFS tokens in
the current PAG (unlog()).
Note that this module doesn't provide a direct way to obtain new AFS
tokens. Programs that need AFS tokens should normally obtain Kerberos
tickets (via whatever means) and then run the program B<aklog>, which
comes with most AFS distributions. This program will create AFS tokens
from the current Kerberos ticket cache and store them in the current PAG.
To isolate those credentials from the rest of the system, call setpag()
before running B<aklog>.
=head1 FUNCTIONS
This module provides the following functions, none of which are exported
by default:
=over 4
=item hasafs()
Returns true if the local host is running an AFS client and false
otherwise.
=item haspag()
Returns true if the current process is running inside a PAG and false
otherwise. AFS tokens obtained outside of a PAG are visible to any
process on the system outside of a PAG running as the same UID. AFS
tokens obtained inside a PAG are visible to any process in the same PAG,
regardless of UID.
=item setpag()
Creates a new, empty PAG and put the current process in it. This should
normally be called before obtaining new AFS tokens to isolate those tokens
from other processes on the system. Returns true on success and throws
an exception on failure.
=item unlog()
Deletes all AFS tokens in the current PAG, similar to the action of
B<kdestroy> on a Kerberos ticket cache. Returns true on success and
throws an exception on failure.
=back
=head1 DIAGNOSTICS
=over 4
=item PAG creation failed: %s
setpag() failed. The end of the error message will be a translation of
the system call error number.
=item Token deletion failed: %s
unlog() failed. The end of the error message will be a translation of
the system call error number.
=back
=head1 RESTRICTIONS
This module currently doesn't provide the k_pioctl() or pioctl() function
to make lower-level AFS system calls. It also doesn't provide the libkafs
functions to obtain AFS tokens from Kerberos tickets directly without using
an external ticket cache. This prevents use of internal Kerberos ticket
caches (such as memory caches), since the Kerberos tickets used to generate
AFS tokens have to be visible to an external B<aklog> program.
=head1 AUTHOR
Russ Allbery <rra@cpan.org>
=head1 SEE ALSO
aklog(1)
The current version of this module is always available from its web site
at L<http://www.eyrie.org/~eagle/software/afs-pag/>.
=cut
AFS
view release on metacpan or search on metacpan
# specific prior written permission.
# THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
# WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#------------------------------------------------------------------------------
use Carp;
require Exporter;
require AutoLoader;
require DynaLoader;
use vars qw(@ISA $VERSION);
@ISA = qw(Exporter AutoLoader DynaLoader);
$VERSION = 'v2.6.4';
@CELL = qw (
configdir
expandcell
getcell
getcellinfo
localcell
);
@MISC = qw (
afsok
checkafs
setpag
);
@PTS = qw (
newpts
ascii2ptsaccess
ptsaccess2ascii
);
@CM = qw (
cm_access
checkconn
checkservers
checkvolumes
flush
flushcb
flushvolume
getcacheparms
getcellstatus
getfid
getquota
getvolstats
isafs
lsmount
mkmount
pioctl
rmmount
setcachesize
setcellstatus
setquota
sysname
unlog
whereis
whichcell
wscell
get_server_version
get_syslib_version
XSVERSION
getcrypt
setcrypt
);
@ACL = qw (
ascii2rights
cleanacl
copyacl
crights
getacl
modifyacl
newacl
rights2ascii
setacl
);
@KA = qw (
ka_AuthServerConn
NOP_ka_Authenticate
ka_CellToRealm
ka_ExpandCell
ka_GetAdminToken
ka_GetAuthToken
ka_GetServerToken
ka_LocalCell
ka_ParseLoginName
ka_ReadPassword
ka_SingleServerConn
ka_StringToKey
ka_UserAthenticateGeneral
ka_UserReadPassword
ka_des_string_to_key
ka_nulltoken
);
@KTC = qw (
ktc_ForgetAllTokens
ktc_GetToken
ktc_ListTokens
ktc_SetToken
ktc_principal
newprincipal
);
# Items to export into callers namespace by default
# (move infrequently used names to @EXPORT_OK below)
@EXPORT = (@CELL, @MISC, @PTS, @CM, @ACL, @KA, @KTC);
# Other items we are prepared to export if requested
@EXPORT_OK = qw(
raise_exception
constant
convert_numeric_names
AHA
view release on metacpan or search on metacpan
example/lava_lamp.pl view on Meta::CPAN
#!/usr/bin/perl
=head1 NAME
lava_lamp.pl --mode [watch|list|notify] --type [problem|recovery] \
--name [AIN|switch name] --label <label> --debug \
--config <path-to-perl-config>
=head1 DESCRIPTION
Simple example how to use L<"AHA"> for controlling AVM AHA switches. I.e.
it is used for using a Lava Lamp as a Nagios Notification handler.
It also tries to check that:
=over
=item *
The lamp can be switched on only during certain time periods
=item *
The lamp doesn't run longer than a maximum time (e.g. 6 hours)
(C<$LAMP_MAX_TIME>)
=item *
That the lamp is not switched on again after being switched off within a
certain time period (C<$LAMP_REST_TIME>)
=item *
That manual switches are detected and recorded
=back
This script knows three modes:
=over
=item watch
The "watch" mode is used for ensuring that the lamp is not switched on for
certain time i.e. during the night. The Variable C<$LAMP_ON_TIME_TABLE> can be
used to customize the time ranges on a weekday basis.
=item notify
The "notify" mode is used by a notification handler, e.g. from Nagios or from
Jenkins. In this mode, the C<type> parameter is used for signaling whether the
lamp should be switched on ("problem") or off ("recovery").
=item list
This scripts logs all activities in a log file C<$LOG_FILE>. With the "list"
mode, all history entries can be viewed.
=back
=cut
# ===========================================================================
# Configuration section
# Configuration required for accessing the switch.
my $SWITCH_CONFIG =
{
# AVM AHA Host for controlling the devices
host => "fritz.box",
# AVM AHA Password for connecting to the $AHA_HOST
password => "s!cr!t",
# AVM AHA user role (undef if no roles are in use)
user => undef,
# Name of AVM AHA switch
id => "Lava Lamp"
};
# Time how long the lamp should be at least be kept switched off (seconds)
my $LAMP_REST_TIME = 60 * 60;
# Maximum time a lamp can be on
my $LAMP_MAX_TIME = 5 * 60 * 60; # 5 hours
# When the lamp can be switched on. The values can contain multiple time
# windows defined as arrays
my $LAMP_ON_TIME_TABLE =
{
"Sun" => [ ["7:55", "23:00"] ],
"Mon" => [ ["6:55", "23:00"] ],
"Tue" => [ ["13:55", "23:00"] ],
"Wed" => [ ["13:55", "23:00"] ],
"Thu" => [ ["13:55", "23:00"] ],
"Fri" => [ ["6:55", "23:00"] ],
"Sat" => [ ["7:55", "23:00"] ],
};
# File holding the lamp's status
my $STATUS_FILE = "/var/run/lamp.status";
# Log file where to log to
my $LOG_FILE = "/var/log/lamp.log";
# Stop file, when, if exists, keeps the lamp off
my $OFF_FILE = "/tmp/lamp_off";
# Time back in passed assumed when switching was done manually (seconds)
# I.e. if a manual state change is detected, it is assumed that it was back
# that amount of seconds in the past (5 minutes here)
my $MANUAL_DELTA = 5 * 60;
# Maximum number of history entries to store
my $MAX_HISTORY_ENTRIES = 1000;
# ============================================================================
# End of configuration
use Storable qw(fd_retrieve store_fd store retrieve);
use Data::Dumper;
use feature qw(say);
use Fcntl qw(:flock);
use Getopt::Long;
use strict;
my %opts = ();
GetOptions(\%opts, 'type=s','mode=s','debug!','name=s','label=s','config=s');
my $DEBUG = $opts{debug};
read_config_file($opts{config}) if $opts{config};
init_status();
my $mode = $opts{'mode'} || "list";
# List mode doesnt need a connection
list() and exit if $mode eq "list";
# Open status and lock
my $status = fetch_status();
# Name and connection parameters
my $lamp = open_lamp($SWITCH_CONFIG,$opts{name});
# Check current switch state
my $is_on = $lamp->is_on();
# Log a manual switch which might has happened in between checks or notification
log_manual_switch($status,$is_on);
if ($mode eq "watch") {
# Watchdog mode If the lamp is on but out of the period, switch it
# off. Also, if it is running alredy for too long. $off_file can be used
# to switch it always off.
my $in_period = check_on_period();
if ($is_on && (-e $OFF_FILE ||
!$in_period ||
lamp_on_for_too_long($status))) {
# Switch off lamp whether the stop file is switched on when we are off the
# time window
$lamp->off();
update_status($status,0,$mode);
} elsif (!$is_on && $in_period && has_trigger($status)) {
$lamp->on();
update_status($status,1,"notif",undef,trigger_label($status));
delete_trigger($status);
}
} elsif ($mode eq "notif") {
my $type = $opts{type} || die "No notification type given";
if (lc($type) =~ /^(problem|custom)$/ && !$is_on) {
if (check_on_period()) {
# If it is a problem and the lamp is not on, switch it on,
# but only if the lamp is not 'hot' (i.e. was not switch off only
# $LAMP_REST_TIME
my $last_hist = get_last_entry($status);
my $rest_time = time - $LAMP_REST_TIME;
if (!$last_hist || $last_hist->[0] < $rest_time) {
$lamp->on();
update_status($status,1,$mode,time,$opts{label});
} else {
info("Lamp not switched on because the lamp was switched off just before ",
time - $last_hist->[0]," seconds");
}
} else {
# Notification received offtime, remember to switch on the lamp
# when in time
info("Notification received in an off-period: type = ",$type," | ",$opts{label});
set_trigger($status,$opts{label});
}
} elsif (lc($type) eq 'recovery') {
if ($is_on) {
# If it is a recovery switch it off
$lamp->off();
update_status($status,0,$mode,time,$opts{label});
} else {
# It's already off, but remove any trigger marker
delete_trigger($status);
}
} else {
info("Notification: No state change. Type = ",$type,", State = ",$is_on ? "On" : "Off",
" | Check Period: ",check_on_period());
}
} else {
die "Unknow mode '",$mode,"'";
}
if ($DEBUG) {
info(Dumper($status));
}
# Logout, we are done
close_lamp($lamp);
store_status($status);
# ================================================================================================
sub info {
if (open (F,">>$LOG_FILE")) {
print F scalar(localtime),": ",join("",@_),"\n";
close F;
}
}
# List the status file
sub list {
my $status = retrieve $STATUS_FILE;
my $hist_entries = $status->{hist};
for my $hist (@{$hist_entries}) {
print scalar(localtime($hist->[0])),": ",$hist->[1] ? "On " : "Off"," -- ",$hist->[2]," : ",$hist->[3],"\n";
}
print "Content: ",Dumper($status) if $DEBUG;
return 1;
}
# Create empty status file if necessary
sub init_status {
my $status = {};
$status->{hist} = [];
if (! -e $STATUS_FILE) {
store $status,$STATUS_FILE;
}
}
sub log_manual_switch {
my $status = shift;
my $is_on = shift;
my $last = get_last_entry($status);
if ($last && $is_on != $last->[1]) {
# Change has been manualy in between the interval. Add an approx history entry
update_status($status,$is_on,"manual",estimate_manual_time($status));
}
}
sub update_status {
my $status = shift;
my $is_on = shift;
my $mode = shift;
my $time = shift || time;
my $label = shift;
my $hist = $status->{hist};
push @{$hist},[ $time, $is_on, $mode, $label];
info($is_on ? "On " : "Off"," -- ",$mode, $label ? ": " . $label : "");
}
sub estimate_manual_time {
my $status = shift;
my $last_hist = get_last_entry($status);
if ($last_hist) {
my $now = time;
my $last = $last_hist->[0];
my $calc = $now - $MANUAL_DELTA;
return $calc > $last ? $calc : $now - int(($now - $last) / 2);
} else {
return time - $MANUAL_DELTA;
}
}
sub get_last_entry {
my $status = shift;
if ($status) {
my $hist = $status->{hist};
return $hist && @$hist ? $hist->[$#{$hist}] : undef;
}
return undef;
}
sub check_on_period {
my ($min,$hour,$wd) = (localtime)[1,2,6];
my $day = qw(Sun Mon Tue Wed Thu Fri Sat)[$wd];
my $periods = $LAMP_ON_TIME_TABLE->{$day};
for my $period (@$periods) {
my ($low,$high) = @$period;
my ($lh,$lm) = split(/:/,$low);
my ($hh,$hm) = split(/:/,$high);
my $m = $hour * 60 + $min;
return 1 if $m >= ($lh * 60 + $lm) && $m <= ($hh * 60 + $hm);
}
return 0;
}
sub lamp_on_for_too_long {
my $status = shift;
# Check if the lamp was on for more than max time in the duration now - max
example/lava_lamp.pl view on Meta::CPAN
my $label = shift;
$status->{trigger_mark} = 1;
$status->{trigger_label} = $label;
}
sub has_trigger {
return shift->{trigger_mark};
}
sub trigger_label {
return shift->{trigger_label};
}
# ====================================================
# Status file handling including locking
my $status_fh;
sub fetch_status {
open ($status_fh,"+<$STATUS_FILE") || die "Cannot open $STATUS_FILE: $!";
$status = fd_retrieve($status_fh) || die "Cannot read $STATUS_FILE: $!";
flock($status_fh,2);
return $status;
}
sub store_status {
my $status = shift;
# Truncate history if necessary
truncate_hist($status);
# Store status and unlock
seek($status_fh, 0, 0); truncate($status_fh, 0);
store_fd $status,$status_fh;
close $status_fh;
}
sub truncate_hist {
my $status = shift;
my $hist = $status->{hist};
my $len = scalar(@$hist);
splice @$hist,0,$len - $MAX_HISTORY_ENTRIES if $len > $MAX_HISTORY_ENTRIES;
$status->{hist} = $hist;
}
# ==========================================================================
# Customize the following call and class in order to use a different
# switch than AVM AHA's
sub open_lamp {
my $config = shift;
my $name = shift || $config->{id};
return new Lamp($name,
$config->{host},
$config->{password},
$config->{user});
}
sub close_lamp {
my $lamp = shift;
$lamp->logout();
}
package Lamp;
use AHA;
sub new {
my $class = shift;
my $name = shift;
my $host = shift;
my $password = shift;
my $user = shift;
my $aha = new AHA($host,$password,$user);
my $switch = new AHA::Switch($aha,$name);
my $self = {
aha => $aha,
switch => $switch
};
return bless $self,$class;
}
sub is_on {
shift->{switch}->is_on();
}
sub on {
shift->{switch}->on();
}
sub off {
shift->{switch}->off();
}
sub logout {
shift->{aha}->logout();
}
=head1 LICENSE
lava_lampl.pl is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 2 of the License, or
(at your option) any later version.
lava_lamp.pl is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with lava_lamp.pl. If not, see <http://www.gnu.org/licenses/>.
=head1 AUTHOR
roland@cpan.org
=cut
AI-ANN
view release on metacpan or search on metacpan
lib/AI/ANN.pm view on Meta::CPAN
}
sub backprop {
my $self = shift;
my $inputs = shift;
my $desired = shift;
my $actual = $self->execute($inputs);
my $net = $self->{'network'};
my $lastneuron = $#{$net};
my $deltas = [];
my $i = 0;
foreach my $neuron (@{$self->outputneurons()}) {
$deltas->[$neuron] = $desired->[$i] - $actual->[$i];
$i++;
}
my $progress = 0;
foreach my $neuron (reverse 0..$lastneuron) {
foreach my $i (reverse $neuron..$lastneuron) {
my $weight = $net->[$i]->{'object'}->neurons()->[$neuron];
if (defined $weight && $weight != 0 && $deltas->[$i]) {
$deltas->[$neuron] += $weight * $deltas->[$i];
}
}
} # Finished generating deltas
foreach my $neuron (0..$lastneuron) {
my $inputinputs = $net->[$neuron]->{'object'}->inputs();
my $neuroninputs = $net->[$neuron]->{'object'}->neurons();
my $dafunc = &{$self->{'dafunc'}}($self->{'rawpotentials'}->[$neuron]);
my $delta = $deltas->[$neuron] || 0;
foreach my $i (0..$#{$inputinputs}) {
$inputinputs->[$i] += $inputs->[$i]*$self->{'backprop_eta'}*$delta*$dafunc;
}
foreach my $i (0..$#{$neuroninputs}) {
$neuroninputs->[$i] += $net->[$i]->{'state'}*$self->{'backprop_eta'}*$delta*$dafunc;
}
$net->[$neuron]->{'object'}->inputs($inputinputs);
$net->[$neuron]->{'object'}->neurons($neuroninputs);
} # Finished changing weights.
}
__PACKAGE__->meta->make_immutable;
1;
__END__
=pod
=head1 NAME
AI::ANN - an artificial neural network simulator
=head1 VERSION
version 0.008
=head1 SYNOPSIS
AI::ANN is an artificial neural network simulator. It differs from existing
solutions in that it fully exposes the internal variables and allows - and
forces - the user to fully customize the topology and specifics of the
produced neural network. If you want a simple solution, you do not want this
module. This module was specifically written to be used for a simulation of
evolution in neural networks, not training. The traditional 'backprop' and
similar training methods are not (currently) implemented. Rather, we make it
easy for a user to specify the precise layout of their network (including both
topology and weights, as well as many parameters), and to then retrieve those
details. The purpose of this is to allow an additional module to then tweak
these values by a means that models evolution by natural selection. The
canonical way to do this is the included AI::ANN::Evolver, which allows
the addition of random mutations to individual networks, and the crossing of
two networks. You will also, depending on your application, need a fitness
function of some sort, in order to determine which networks to allow to
propagate. Here is an example of that system.
use AI::ANN;
my $network = new AI::ANN ( input_count => $inputcount, data => \@neuron_definition );
my $outputs = $network->execute( \@inputs ); # Basic network use
use AI::ANN::Evolver;
my $handofgod = new AI::ANN::Evolver (); # See that module for calling details
my $network2 = $handofgod->mutate($network); # Random mutations
# Test an entire 'generation' of networks, and let $network and $network2 be
# among those with the highest fitness function in the generation.
my $network3 = $handofgod->crossover($network, $network2);
# Perhaps mutate() each network either before or after the crossover to
# introduce variety.
We elected to do this with a new module rather than by extending an existing
module because of the extensive differences in the internal structure and the
interface that were necessary to accomplish these goals.
=head1 METHODS
=head2 new
ANN::new(input_count => $inputcount, data => [{ iamanoutput => 0, inputs => {$inputid => $weight, ...}, neurons => {$neuronid => $weight}}, ...])
input_count is number of inputs.
data is an arrayref of neuron definitions.
The first neuron with iamanoutput=1 is output 0. The second is output 1.
I hope you're seeing the pattern...
minvalue is the minimum value a neuron can pass. Default 0.
maxvalue is the maximum value a neuron can pass. Default 1.
afunc is a reference to the activation function. It should be simple and fast.
The activation function is processed /after/ minvalue and maxvalue.
dafunc is the derivative of the activation function.
We strongly advise that you memoize your afunc and dafunc if they are at all
complicated. We will do our best to behave.
=head2 execute
$network->execute( [$input0, $input1, ...] )
Runs the network for as many iterations as necessary to achieve a stable
network, then returns the output.
We store the current state of the network in two places - once in the object,
for persistence, and once in $neurons, for simplicity. This might be wrong,
but I couldn't think of a better way.
=head2 get_state
$network->get_state()
Returns three arrayrefs, [$input0, ...], [$neuron0, ...], [$output0, ...],
corresponding to the data from the last call to execute().
Intended primarily to assist with debugging.
AI-Calibrate
view release on metacpan or search on metacpan
Revision history for Perl extension AI::Calibrate.
1.5 Fri Aug 3 2012
- Changes to ./t/AI-Calibrate-1.t to let it pass with almost-equal
numbers.
1.4 Thu Aug 2 2012
- Revised calibration algorithm based on bug
- Updated tests in ./t
- Added ./t/AI-Calibrate-KL.t using Kun Liu's dataset.
- Added ./t/AI-Calibrate-pathologies.t to test for pathological cases.
1.3 Fri Nov 4
- Removed dependency on Test::Deep, added explicit declaration of
dependency on Test::More to Makefile.PL
1.2 Thu Nov 3
- Fixed test ./t/AI-Calibrate-NB.t so that test wouldn't fail. Used to
call is_deeply, which was failing on slight differences between
floating point numbers. Now compares with a small tolerance.
1.1 Thu Feb 28 19:00:06 2008
- Added new function print_mapping
- Added new test file AI-Calibrate-NB.t which, if AI::NaiveBayes1 is
present, trains a classifier and calibrates it.
1.0 Thu Feb 05 11:37:31 2008
- First public release to CPAN.
0.01 Thu Jan 24 11:37:31 2008
- original version; created by h2xs 1.23 with options
-XA -n AI::Calibrate
AI-Categorizer
view release on metacpan or search on metacpan
lib/AI/Categorizer.pm view on Meta::CPAN
=over 4
=item AI::Categorizer::Learner::NaiveBayes
A pure-perl implementation of a Naive Bayes classifier. No
dependencies on external modules or other resources. Naive Bayes is
usually very fast to train and fast to make categorization decisions,
but isn't always the most accurate categorizer.
=item AI::Categorizer::Learner::SVM
An interface to Corey Spencer's C<Algorithm::SVM>, which implements a
Support Vector Machine classifier. SVMs can take a while to train
(though in certain conditions there are optimizations to make them
quite fast), but are pretty quick to categorize. They often have very
good accuracy.
=item AI::Categorizer::Learner::DecisionTree
An interface to C<AI::DecisionTree>, which implements a Decision Tree
classifier. Decision Trees generally take longer to train than Naive
Bayes or SVM classifiers, but they are also quite fast when
categorizing. Decision Trees have the advantage that you can
scrutinize the structures of trained decision trees to see how
decisions are being made.
=item AI::Categorizer::Learner::Weka
An interface to version 2 of the Weka Knowledge Analysis system that
lets you use any of the machine learners it defines. This gives you
access to lots and lots of machine learning algorithms in use by
machine learning researches. The main drawback is that Weka tends to
be quite slow and use a lot of memory, and the current interface
between Weka and C<AI::Categorizer> is a bit clumsy.
=back
Other machine learning methods that may be implemented soonish include
Neural Networks, k-Nearest-Neighbor, and/or a mixture-of-experts
combiner for ensemble learning. No timetable for their creation has
yet been set.
Please see the documentation of these individual modules for more
details on their guts and quirks. See the C<AI::Categorizer::Learner>
documentation for a description of the general categorizer interface.
If you wish to create your own classifier, you should inherit from
C<AI::Categorizer::Learner> or C<AI::Categorizer::Learner::Boolean>,
which are abstract classes that manage some of the work for you.
=head2 Feature Vectors
Most categorization algorithms don't deal directly with documents'
data, they instead deal with a I<vector representation> of a
document's I<features>. The features may be any properties of the
document that seem helpful for determining its category, but they are usually
some version of the "most important" words in the document. A list of
features and their weights in each document is encapsulated by the
C<AI::Categorizer::FeatureVector> class. You may think of this class
as roughly analogous to a Perl hash, where the keys are the names of
features and the values are their weights.
=head2 Hypotheses
The result of asking a categorizer to categorize a previously unseen
document is called a hypothesis, because it is some kind of
"statistical guess" of what categories this document should be
assigned to. Since you may be interested in any of several pieces of
information about the hypothesis (for instance, which categories were
assigned, which category was the single most likely category, the
scores assigned to each category, etc.), the hypothesis is returned as
an object of the C<AI::Categorizer::Hypothesis> class, and you can use
its object methods to get information about the hypothesis. See its
class documentation for the details.
=head2 Experiments
The C<AI::Categorizer::Experiment> class helps you organize the
results of categorization experiments. As you get lots of
categorization results (Hypotheses) back from the Learner, you can
feed these results to the Experiment class, along with the correct
answers. When all results have been collected, you can get a report
on accuracy, precision, recall, F1, and so on, with both
micro-averaging and macro-averaging over categories. We use the
C<Statistics::Contingency> module from CPAN to manage the
calculations. See the docs for C<AI::Categorizer::Experiment> for more
details.
=head1 METHODS
=over 4
=item new()
Creates a new Categorizer object and returns it. Accepts lots of
parameters controlling behavior. In addition to the parameters listed
here, you may pass any parameter accepted by any class that we create
internally (the KnowledgeSet, Learner, Experiment, or Collection
classes), or any class that I<they> create. This is managed by the
C<Class::Container> module, so see
L<its documentation|Class::Container> for the details of how this
works.
The specific parameters accepted here are:
=over 4
=item progress_file
A string that indicates a place where objects will be saved during
several of the methods of this class. The default value is the string
C<save>, which means files like C<save-01-knowledge_set> will get
created. The exact names of these files may change in future
releases, since they're just used internally to resume where we last
left off.
=item verbose
If true, a few status messages will be printed during execution.
AI-Classifier
view release on metacpan or search on metacpan
lib/AI/Classifier/Text/FileLearner.pm view on Meta::CPAN
my $learner = $self->learner;
while ( my $data = $self->next ) {
normalize( $data->{features} );
$self->weight_terms($data);
$learner->add_example(
attributes => $data->{features},
labels => $data->{categories}
);
}
}
sub classifier {
my $self = shift;
$self->teach_it;
return AI::Classifier::Text->new(
classifier => $self->learner->classifier,
analyzer => $self->analyzer,
);
}
sub weight_terms {
my ( $self, $doc ) = @_;
my $f = $doc->{features};
given ($self->term_weighting) {
when ('n') {
my $max_tf = max values %$f;
$_ = 0.5 + 0.5 * $_ / $max_tf for values %$f;
}
when ('b') {
$_ = $_ ? 1 : 0 for values %$f;
}
when (undef){
}
default {
croak 'Unknown weighting type: '.$self->term_weighting;
}
}
}
# this doesn't quite fit the current model (it requires the entire collection
# of documents to be in memory at once), but it may be useful to someone, someday
# so let's just leave it here
sub collection_weighting {
my (@documents, $subtrahend) = @_;
$subtrahend //= 0;
my $num_docs = +@documents;
my %frequency;
for my $doc (@documents) {
for my $k (keys %{$doc->{attributes}}) {
$frequency{$k}++;
}
}
foreach my $doc (@documents) {
my $f = $doc->{attributes};
for (keys %$f) {
$f->{$_} *= log($num_docs / ($frequency{$_} // 0) - $subtrahend);
}
}
}
sub euclidean_length {
my $f = shift;
my $total = 0;
foreach (values %$f) {
$total += $_**2;
}
return sqrt($total);
}
sub scale {
my ($f, $scalar) = @_;
$_ *= $scalar foreach values %$f;
return $f;
}
sub normalize {
my $attrs = shift;
my $length = euclidean_length($attrs);
return $length ? scale($attrs, 1/$length) : $attrs;
}
1;
=pod
=head1 NAME
AI::Classifier::Text::FileLearner - Training data reader for AI::NaiveBayes
=head1 VERSION
version 0.03
=head1 SYNOPSIS
use AI::Classifier::Text::FileLearner;
my $learner = AI::Classifier::Text::FileLearner->new( training_dir => 't/data/training_set_ordered/' );
my $classifier = $learner->classifier;
=head1 DESCRIPTION
This is a trainer of text classifiers. It traverses a directory filled,
interprets the subdirectories in it as category names, reads all files in them and adds them
as examples for the classifier being trained.
head1 METHODS
=over 4
AI-CleverbotIO
view release on metacpan or search on metacpan
lib/AI/CleverbotIO.pm view on Meta::CPAN
package AI::CleverbotIO;
use strict;
use warnings;
{ our $VERSION = '0.002'; }
use Moo;
use Ouch;
use Log::Any ();
use Data::Dumper;
use JSON::PP qw< decode_json >;
has endpoints => (
is => 'ro',
default => sub {
return {
ask => 'https://cleverbot.io/1.0/ask',
create => 'https://cleverbot.io/1.0/create',
};
},
);
has key => (
is => 'ro',
required => 1,
);
has logger => (
is => 'ro',
lazy => 1,
builder => 'BUILD_logger',
);
has nick => (
is => 'rw',
lazy => 1,
predicate => 1,
);
has user => (
is => 'ro',
required => 1,
);
has ua => (
is => 'ro',
lazy => 1,
builder => 'BUILD_ua',
);
sub BUILD_logger {
return Log::Any->get_logger;
}
sub BUILD_ua {
my $self = shift;
require HTTP::Tiny;
return HTTP::Tiny->new;
}
sub ask {
my ($self, $question) = @_;
my %ps = (
key => $self->key,
text => $question,
user => $self->user,
);
$ps{nick} = $self->nick if $self->has_nick;
return $self->_parse_response(
$self->ua->post_form($self->endpoints->{ask}, \%ps));
}
sub create {
my $self = shift;
$self->nick(shift) if @_;
# build request parameters
my %ps = (
key => $self->key,
user => $self->user,
);
$ps{nick} = $self->nick if $self->has_nick && length $self->nick;
my $data =
$self->_parse_response(
$self->ua->post_form($self->endpoints->{create}, \%ps));
$self->nick($data->{nick}) if exists($data->{nick});
return $data;
}
sub _parse_response {
my ($self, $response) = @_;
{
local $Data::Dumper::Indent = 1;
$self->logger->debug('got response: ' . Dumper($response));
}
ouch 500, 'no response (possible bug in HTTP::Tiny though?)'
unless ref($response) eq 'HASH';
my $status = $response->{status};
ouch $status, $response->{reason}
if ($status != 200) && ($status != 400);
my $data = __decode_content($response);
return $data if $response->{success};
ouch 400, $data->{status};
} ## end sub _parse_response
sub __decode_content {
my $response = shift;
my $encoded = $response->{content};
if (!$encoded) {
my $url = $response->{url} // '*unknown url, check HTTP::Tiny*';
ouch 500, "response status $response->{status}, nothing from $url)";
}
my $decoded = eval { decode_json($encoded) }
or ouch 500, "response status $response->{status}, exception: $@";
return $decoded;
} ## end sub __decode_content
1;
AI-ConfusionMatrix
view release on metacpan or search on metacpan
name = AI-ConfusionMatrix
author = Vincent Lequertier <vi.le@autistici.org>
license = Perl_5
copyright_holder = Vincent Lequertier
copyright_year = 2019
version = 0.010
[MetaResources]
bugtracker.web = http://rt.cpan.org/NoAuth/Bugs.html?AI-ConfusionMatrix
bugtracker.mailto = bug-ai-confusionmatrix@rt.cpan.org
repository.url = https://gitlab.com/vi.le/perl-ai-confusionmatrix.git
repository.web = https://gitlab.com/vi.le/perl-ai-confusionmatrix
repository.type = git
[AutoPrereqs]
[ChangelogFromGit]
file_name = Changes
max_age = 730
[CopyFilesFromBuild]
copy = cpanfile
copy = LICENSE
copy = Makefile.PL
copy = README.md
[GatherDir]
exclude_filename = cpanfile
exclude_filename = LICENSE
exclude_filename = Makefile.PL
exclude_filename = .gitlab-ci.yml
exclude_match = ~$
exclude_match = tags
[License]
[MetaYAML]
[MetaJSON]
[MetaProvides::Package]
[MakeMaker]
[ManifestSkip]
[Manifest]
[PkgVersion]
[PodSyntaxTests]
[ReadmeAnyFromPod]
type = markdown
filename = README.md
location = build
AI-DecisionTree
view release on metacpan or search on metacpan
lib/AI/DecisionTree.pm view on Meta::CPAN
my $best_attr = $self->best_attr($instances);
croak "Inconsistent data, can't build tree with noise_mode='fatal'"
if $self->{noise_mode} eq 'fatal' and !defined $best_attr;
if ( !defined($best_attr)
or $self->{max_depth} && $self->{curr_depth} > $self->{max_depth} ) {
# Pick the most frequent result for this leaf
$node{result} = (sort {$results{$b} <=> $results{$a}} keys %results)[0];
return \%node;
}
$node{split_on} = $best_attr;
my %split;
foreach my $i (@$instances) {
my $v = $self->_value($i, $best_attr);
push @{$split{ defined($v) ? $v : '<undef>' }}, $i;
}
die ("Something's wrong: attribute '$best_attr' didn't split ",
scalar @$instances, " instances into multiple buckets (@{[ keys %split ]})")
unless keys %split > 1;
foreach my $value (keys %split) {
$node{children}{$value} = $self->_expand_node( instances => $split{$value} );
}
return \%node;
}
sub best_attr {
my ($self, $instances) = @_;
# 0 is a perfect score, entropy(#instances) is the worst possible score
my ($best_score, $best_attr) = (@$instances * $self->entropy( map $_->result_int, @$instances ), undef);
my $all_attr = $self->{attributes};
foreach my $attr (keys %$all_attr) {
# %tallies is correlation between each attr value and result
# %total is number of instances with each attr value
my (%totals, %tallies);
my $num_undef = AI::DecisionTree::Instance::->tally($instances, \%tallies, \%totals, $all_attr->{$attr});
next unless keys %totals; # Make sure at least one instance defines this attribute
my $score = 0;
while (my ($opt, $vals) = each %tallies) {
$score += $totals{$opt} * $self->entropy2( $vals, $totals{$opt} );
}
($best_attr, $best_score) = ($attr, $score) if $score < $best_score;
}
return $best_attr;
}
sub entropy2 {
shift;
my ($counts, $total) = @_;
# Entropy is defined with log base 2 - we just divide by log(2) at the end to adjust.
my $sum = 0;
$sum += $_ * log($_) foreach values %$counts;
return +(log($total) - $sum/$total)/log(2);
}
sub entropy {
shift;
my %count;
$count{$_}++ foreach @_;
# Entropy is defined with log base 2 - we just divide by log(2) at the end to adjust.
my $sum = 0;
$sum += $_ * log($_) foreach values %count;
return +(log(@_) - $sum/@_)/log(2);
}
sub prune_tree {
my $self = shift;
# We use a minimum-description-length approach. We calculate the
# score of each node:
# n = number of nodes below
# r = number of results (categories) in the entire tree
# i = number of instances in the entire tree
# e = number of errors below this node
# Hypothesis description length (MML):
# describe tree: number of nodes + number of edges
# describe exceptions: num_exceptions * log2(total_num_instances) * log2(total_num_results)
my $r = keys %{ $self->{results} };
my $i = $self->{tree}{instances};
my $exception_cost = log($r) * log($i) / log(2)**2;
# Pruning can turn a branch into a leaf
my $maybe_prune = sub {
my ($self, $node) = @_;
return unless $node->{children}; # Can't prune leaves
my $nodes_below = $self->nodes_below($node);
my $tree_cost = 2 * $nodes_below - 1; # $edges_below == $nodes_below - 1
my $exceptions = $self->exceptions( $node );
my $simple_rule_exceptions = $node->{instances} - $node->{distribution}[1];
my $score = -$nodes_below - ($exceptions - $simple_rule_exceptions) * $exception_cost;
#warn "Score = $score = -$nodes_below - ($exceptions - $simple_rule_exceptions) * $exception_cost\n";
if ($score < 0) {
delete @{$node}{'children', 'split_on', 'exceptions', 'nodes_below'};
$node->{result} = $node->{distribution}[0];
# XXX I'm not cleaning up 'exceptions' or 'nodes_below' keys up the tree
}
};
$self->_traverse($maybe_prune);
}
sub exceptions {
my ($self, $node) = @_;
return $node->{exceptions} if exists $node->{exeptions};
my $count = 0;
if ( exists $node->{result} ) {
$count = $node->{instances} - $node->{distribution}[1];
} else {
foreach my $child ( values %{$node->{children}} ) {
$count += $self->exceptions($child);
}
}
return $node->{exceptions} = $count;
}
sub nodes_below {
my ($self, $node) = @_;
return $node->{nodes_below} if exists $node->{nodes_below};
my $count = 0;
$self->_traverse( sub {$count++}, $node );
return $node->{nodes_below} = $count - 1;
}
# This is *not* for external use, I may change it.
sub _traverse {
my ($self, $callback, $node, $parent, $node_name) = @_;
$node ||= $self->{tree};
ref($callback) ? $callback->($self, $node, $parent, $node_name) : $self->$callback($node, $parent, $node_name);
return unless $node->{children};
foreach my $child ( keys %{$node->{children}} ) {
$self->_traverse($callback, $node->{children}{$child}, $node, $child);
AI-Embedding
view release on metacpan or search on metacpan
lib/AI/Embedding.pm view on Meta::CPAN
if (scalar keys %$vector1 != scalar keys %$vector2) {
$self->{'error'} = 'Embeds are unequal length';
return;
}
return $self->_compare_vector($vector1, $vector2);
}
# Compare 2 Vectors
sub _compare_vector {
my ($self, $vector1, $vector2) = @_;
my $cs = Data::CosineSimilarity->new;
$cs->add( label1 => $vector1 );
$cs->add( label2 => $vector2 );
return $cs->similarity('label1', 'label2')->cosine;
}
1;
__END__
=encoding utf8
=head1 NAME
AI::Embedding - Perl module for working with text embeddings using various APIs
=head1 VERSION
Version 1.11
=head1 SYNOPSIS
use AI::Embedding;
my $embedding = AI::Embedding->new(
api => 'OpenAI',
key => 'your-api-key'
);
my $csv_embedding = $embedding->embedding('Some sample text');
my $test_embedding = $embedding->test_embedding('Some sample text');
my @raw_embedding = $embedding->raw_embedding('Some sample text');
my $cmp = $embedding->comparator($csv_embedding2);
my $similarity = $cmp->($csv_embedding1);
my $similarity_with_other_embedding = $embedding->compare($csv_embedding1, $csv_embedding2);
=head1 DESCRIPTION
The L<AI::Embedding> module provides an interface for working with text embeddings using various APIs. It currently supports the L<OpenAI|https://www.openai.com> L<Embeddings API|https://platform.openai.com/docs/guides/embeddings/what-are-embeddings>...
Embeddings allow the meaning of passages of text to be compared for similarity. This is more natural and useful to humans than using traditional keyword based comparisons.
An Embedding is a multi-dimensional vector representing the meaning of a piece of text. The Embedding vector is created by an AI Model. The default model (OpenAI's C<text-embedding-ada-002>) produces a 1536 dimensional vector. The resulting vector...
=head2 Comparator
Embeddings are used to compare similarity of meaning between two passages of text. A typical work case is to store a number of pieces of text (e.g. articles or blogs) in a database and compare each one to some user supplied search text. L<AI::Embed...
Alternatively, the C<comparator> method can be called with one Embedding. The C<comparator> returns a reference to a method that takes a single Embedding to be compared to the Embedding from which the Comparator was created.
When comparing multiple Embeddings to the same Embedding (such as search text) it is faster to use a C<comparator>.
=head1 CONSTRUCTOR
=head2 new
my $embedding = AI::Embedding->new(
api => 'OpenAI',
key => 'your-api-key',
model => 'text-embedding-ada-002',
);
Creates a new AI::Embedding object. It requires the 'key' parameter. The 'key' parameter is the API key provided by the service provider and is required.
Parameters:
=over
=item *
C<key> - B<required> The API Key
=item *
C<api> - The API to use. Currently only 'OpenAI' is supported and this is the default.
=item *
C<model> - The language model to use. Defaults to C<text-embedding-ada-002> - see L<OpenAI docs|https://platform.openai.com/docs/guides/embeddings/what-are-embeddings>
=back
=head1 METHODS
=head2 success
Returns true if the last method call was successful
=head2 error
Returns the last error message or an empty string if B<success> returned true
=head2 embedding
my $csv_embedding = $embedding->embedding('Some text passage', [$verbose]);
Generates an embedding for the given text and returns it as a comma-separated string. The C<embedding> method takes a single parameter, the text to generate the embedding for.
Returns a (rather long) string that can be stored in a C<TEXT> database field.
If the method call fails it sets the L</"error"> message and returns C<undef>. If the optional C<verbose> parameter is true, the complete L<HTTP::Tiny> response object is also returned to aid with debugging issues when using this module.
=head2 raw_embedding
my @raw_embedding = $embedding->raw_embedding('Some text passage', [$verbose]);
Generates an embedding for the given text and returns it as an array. The C<raw_embedding> method takes a single parameter, the text to generate the embedding for.
AI-Evolve-Befunge
view release on metacpan or search on metacpan
Distribution of Compiled Forms of the Standard Version
or Modified Versions without the Source
(5) You may Distribute Compiled forms of the Standard Version without
the Source, provided that you include complete instructions on how to
get the Source of the Standard Version. Such instructions must be
valid at the time of your distribution. If these instructions, at any
time while you are carrying out such distribution, become invalid, you
must provide new instructions on demand or cease further distribution.
If you provide valid instructions or cease distribution within thirty
days after you become aware that the instructions are invalid, then
you do not forfeit any of your rights under this license.
(6) You may Distribute a Modified Version in Compiled form without
the Source, provided that you comply with Section 4 with respect to
the Source of the Modified Version.
Aggregating or Linking the Package
(7) You may aggregate the Package (either the Standard Version or
Modified Version) with other packages and Distribute the resulting
aggregation provided that you do not charge a licensing fee for the
Package. Distributor Fees are permitted, and licensing fees for other
components in the aggregation are permitted. The terms of this license
apply to the use and Distribution of the Standard or Modified Versions
as included in the aggregation.
(8) You are permitted to link Modified and Standard Versions with
other works, to embed the Package in a larger work of your own, or to
build stand-alone binary or bytecode versions of applications that
include the Package, and Distribute the result without restriction,
provided the result does not expose a direct interface to the Package.
Items That are Not Considered Part of a Modified Version
(9) Works (including, but not limited to, modules and scripts) that
merely extend or make use of the Package, do not, by themselves, cause
the Package to be a Modified Version. In addition, such works are not
considered parts of the Package itself, and are not subject to the
terms of this license.
General Provisions
(10) 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.
(11) 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.
(12) This license does not grant you the right to use any trademark,
service mark, tradename, or logo of the Copyright Holder.
(13) 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.
(14) 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.
AI-ExpertSystem-Advanced
view release on metacpan or search on metacpan
inc/Module/Install/Fetch.pm view on Meta::CPAN
#line 1
package Module::Install::Fetch;
use strict;
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '0.91';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
sub get_file {
my ($self, %args) = @_;
my ($scheme, $host, $path, $file) =
$args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) {
$args{url} = $args{ftp_url}
or (warn("LWP support unavailable!\n"), return);
($scheme, $host, $path, $file) =
$args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
}
$|++;
print "Fetching '$file' from $host... ";
unless (eval { require Socket; Socket::inet_aton($host) }) {
warn "'$host' resolve failed!\n";
return;
}
return unless $scheme eq 'ftp' or $scheme eq 'http';
require Cwd;
my $dir = Cwd::getcwd();
chdir $args{local_dir} or return if exists $args{local_dir};
if (eval { require LWP::Simple; 1 }) {
LWP::Simple::mirror($args{url}, $file);
}
elsif (eval { require Net::FTP; 1 }) { eval {
# use Net::FTP to get past firewall
my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600);
$ftp->login("anonymous", 'anonymous@example.com');
$ftp->cwd($path);
$ftp->binary;
$ftp->get($file) or (warn("$!\n"), return);
$ftp->quit;
} }
elsif (my $ftp = $self->can_run('ftp')) { eval {
# no Net::FTP, fallback to ftp.exe
require FileHandle;
my $fh = FileHandle->new;
local $SIG{CHLD} = 'IGNORE';
unless ($fh->open("|$ftp -n")) {
warn "Couldn't open ftp: $!\n";
chdir $dir; return;
}
my @dialog = split(/\n/, <<"END_FTP");
open $host
user anonymous anonymous\@example.com
cd $path
binary
get $file $file
quit
END_FTP
foreach (@dialog) { $fh->print("$_\n") }
$fh->close;
} }
else {
warn "No working 'ftp' program available!\n";
chdir $dir; return;
}
unless (-f $file) {
warn "Fetching failed: $@\n";
chdir $dir; return;
}
return if exists $args{size} and -s $file != $args{size};
system($args{run}) if exists $args{run};
unlink($file) if $args{remove};
print(((!exists $args{check_for} or -e $args{check_for})
? "done!" : "failed! ($!)"), "\n");
chdir $dir; return !$?;
}
1;
( run in 0.932 second using v1.01-cache-2.11-cpan-49f99fa48dc )