App-Office-Contacts

 view release on metacpan or  search on metacpan

scripts/check.org.cgi.fields.pl  view on Meta::CPAN

my(@form_list);

for my $line (path('docs/add.organization.form.html') -> lines)
{
	push @form_list, $line =~ /id="(.+?)"/g;
}

@form_list   = map{s/organization/org/; $_} @form_list;
my($compare) = List::Compare -> new(\@add_list, \@form_list);

say 'Report for add_org logic:';
say 'Items in the add list only:';
say map{"$_\n"} $compare -> get_unique;
say 'Items in the form list only:';
say map{"$_\n"} $compare -> get_complement;
say '-' x 50;

$compare = List::Compare -> new(\@update_list, \@form_list);

say 'Report for update_org logic:';
say 'Items in the update list only:';
say map{"$_\n"} $compare -> get_unique;
say 'Items in the form list only:';
say map{"$_\n"} $compare -> get_complement;
say '-' x 50;

scripts/check.template.pl  view on Meta::CPAN

(
	'note.tx',
	{
		name      => 'A Name',
		note_list =>
		[
		],
	}
);

say $note;

scripts/db.test.pl  view on Meta::CPAN

use DBI;

use DBIx::Simple;

# ---------

my($library) = App::Office::Contacts::Database::Library -> new;
my($logger)  = App::Office::Contacts::Util::Logger -> new;
my($config)  = $logger -> module_config;

say "dsn: $$config{dsn}. username: $$config{username}. password: $$config{password}. ";
say 'Results from DBI:';

my($attr) = {RaiseError => 1};
my($dbh)  = DBI -> connect($$config{dsn}, $$config{username}, $$config{password}, $attr);
my($sql)  = 'select name from people where upper(name) like ? order by name';
my($sth)  = $dbh -> prepare($sql);
my($name) = 'ÉÉ';

$sth -> execute("%$name%");

while (my $record = $sth -> fetch)
{
	say $$record[0];
}

$dbh -> disconnect;

say 'Results from DBIx::Simple:';

my($simple) = DBIx::Simple -> connect($$config{dsn}, $$config{username}, $$config{password}, $attr);
my($result) = $simple -> query('select name from people where upper(name) like ? order by name', "%$name%")
		|| die $simple -> error;
my(@list_1) = $result -> flat; # Not -> list!
my($list_2) = $library -> decode_list(@list_1);

say "Result:  $_" for @list_1;
say "Decoded: $_" for @$list_2;

scripts/pod2html4all.pl  view on Meta::CPAN

my($basename);
my(@html_file, $html_file);

for my $pm_file (Path::Iterator::Rule -> new -> perl_module -> all)
{
	# Ignore Module::Install stuff.

	next if ($pm_file =~ m|^\./inc/|);

	say $pm_file;

	# Convert ./lib/App/Office/Contacts.pm into
	# $DR/Perl-modules/html/App/Office/Contacts.html.
	# Note: $DR is my web server's doc root.

	@html_file = split(m|/|, $pm_file);

	# Discard '.' and 'lib'.

	shift @html_file;
	shift @html_file;

	$basename  = pop @html_file;
	$basename  =~ s/pm$/html/;
	$html_file = join('/', $ENV{DR}, 'Perl-modules', 'html', @html_file);

	`mkdir -p $html_file`;

	$html_file = "$html_file/$basename";

	say $html_file;

	`pod2html.pl -i $pm_file -o $html_file`;
}

scripts/utf8.1.pl  view on Meta::CPAN

use Text::CSV::Encoded;

# ---------------

my(@my_data) = ('Léon Brocard', 'Reichwaldstraße', 'Böhme', 'ʎ ʏ ʐ ʑ ʒ ʓ ʙ ʚ', 'Πηληϊάδεω Ἀχιλῆος', 'ΔΔΔΔΔΔΔΔΔΔΔΔΔΔΔΔΔ');
my(@lc_data) = map{lc} @my_data;
my(@uc_data) = map{uc} @my_data;

open(OUT, '> :encoding(UTF-8)', 'data/utf8.1.log');
say OUT 'row, original, lc, uc';
say OUT "$_, $my_data[$_], $lc_data[$_], $uc_data[$_]" for (0 .. $#lc_data);
close OUT;

my($csv) = Text::CSV::Encoded -> new({allow_whitespace => 1, encoding_in => 'utf8'});
open my $io, '<', 'data/utf8.1.log';
$csv -> column_names($csv -> getline($io) );
my($data) = $csv -> getline_hr_all($io);
close $io;

open(OUT, '> :encoding(UTF-8)', 'data/utf8.2.log');
say OUT 'row, original, lc, uc';
say OUT "$$_{row}, $$_{original}, $$_{lc}, $$_{uc}" for @$data;
close OUT;

say 'data/utf8.1.log should be identical to data/utf8.2.log';

scripts/utf8.2.pl  view on Meta::CPAN

use open      qw(:std :utf8);    # Undeclared streams in UTF-8.
use charnames qw(:full :short);  # Unneeded in v5.16.

use Encode; # For encode() and decode().

# ---------

my($correct) = 'Léon Brocard';
my($copy)    = \$correct;

say "Correct:        $correct";
say "Original:       $$copy (not overwritten the way Encode used to do)";

my($encoded)      = encode('utf-8', $correct);
my($utf8_encoded) = $correct;

utf8::encode($utf8_encoded);

say "Encoded:        $encoded";
say "utf8::encode:   $utf8_encoded";
say "Double encoded: ", encode('utf-8', $encoded);

my($decoded) = decode('utf-8', $correct);

say "Decoded: $decoded";
#say "Double decoded: ", decode('utf-8', $decoded);
say "Original:       $$copy (not overwritten the way Encode used to do)";