1#!/usr/bin/perl 2 3# 4# CDDL HEADER START 5# 6# The contents of this file are subject to the terms of the 7# Common Development and Distribution License (the "License"). 8# You may not use this file except in compliance with the License. 9# 10# See LICENSE.txt included in this distribution for the specific 11# language governing permissions and limitations under the License. 12# 13# When distributing Covered Code, include this CDDL HEADER in each 14# file and include the License file at LICENSE.txt. 15# If applicable, add the following below this CDDL HEADER, with the 16# fields enclosed by brackets "[]" replaced with your own identifying 17# information: Portions Copyright [yyyy] [name of copyright owner] 18# 19# CDDL HEADER END 20# 21 22# 23# Copyright (c) 2010, 2016, Oracle and/or its affiliates. All rights reserved. 24# Portions Copyright (c) 2017, Chris Fraire <cfraire@me.com>. 25# 26 27use warnings; 28 29 use DBI; 30 31 my $database='dbi:DB2:sample'; 32 my $user=''; 33 my $password=''; 34 35 my $dbh = DBI->connect($database, $user, $password) 36 or die "Can't connect to $database: $DBI::errstr"; 37 38 my $sth = $dbh->prepare( 39 q{ SELECT firstnme, lastname 40 FROM employee } 41 ) 42 or die "Can't prepare statement: $DBI::errstr"; 43 44 my $rc = $sth->execute 45 or die "Can't execute statement: $DBI::errstr"; 46 47 print "Query will return $sth->{NUM_OF_FIELDS} fields.\n\n"; 48 print "$sth->{NAME}->[0]: $sth->{NAME}->[1]\n"; 49 50 while (($firstnme, $lastname) = $sth->fetchrow()) { 51 print "$firstnme: $lastname\n"; 52 } 53 54 # check for problems which may have terminated the fetch early 55 warn $DBI::errstr if $DBI::err; 56 57 $sth->finish; 58 $dbh->disconnect; 59 60=item snazzle($) 61 62The snazzle() function will behave in the most spectacular 63form that you can possibly imagine, not even excepting 64cybernetic pyrotechnics. 65 66=cut back to the compiler, nuff of this pod stuff! 67 68sub snazzle($) { 69my $thingie = shift; 70} 71 72my $x; 73$x=12345; # integer 74$x=-54321; # negative integer 75$x=12345.67; # floating point 76$x=6.02E23; # scientific notation 77$x=0xffff; # hexadecimal 78$x=0377; # octal 79$x=4_294_967_296; # underline for legibility 80 81# 82# The following should be marked-up in the same manner as for all sigiled 83# identifiers. 84# 85$s = $var; 86$s = \$var; 87$s = ${var}; 88 89# 90# include "<<EOF" examples from 91# https://perldoc.perl.org/perlop.html#Quote-and-Quote-like-Operators 92# 93 94print <<EOF; 95The price is $Price. 96EOF 97print << "EOF"; # same as above 98The price is $Price. 99EOF 100 101my $cost = <<'VISTA'; # hasta la ... 102That'll be $10 please, ma'am. 103VISTA 104$cost = <<\VISTA; # Same thing! 105That'll be $10 please, ma'am. 106VISTA 107 108print << `EOC`; # execute command and get results 109echo hi there 110EOC 111 112if ($some_var) { 113 print <<~EOF; 114 This is a here-doc 115 EOF 116} 117 118print <<~EOF; 119 This text is not indented 120 This text is indented with two spaces 121 This text is indented with two tabs 122EOF 123 124print <<~ 'EOF'; 125 This text is not indented 126 This text is indented with two spaces 127 This text is indented with two tabs 128EOF 129 130print <<"foo", <<"bar"; # you can stack them 131I said foo. 132foo 133I said bar. 134bar 135 136myfunc(<< "THIS", 23, <<'THAT'); 137Here's a line or 138two 139THIS 140and here's another. 141THAT 142 143# 144# Include some samples for the shortcut // syntax of m// 145# 146 147$var =~ /pP \"\'\(\)\<\>\{\}\[\]\/\# et $var./ && print; 148$var !~/pP \"\'\(\)\<\>\{\}\[\]\/\# et $var./ && print; 149/pP \"\'\(\)\<\>\{\}\[\]\/\# et $var./ && print; 150(/pP \"\'\(\)\<\>\{\}\[\]\/\# et $var./) && print; 151if (/pP \"\'\(\)\<\>\{\}\[\]\/\# et $var./) { print; } 152if (1 && /pP \"\'\(\)\<\>\{\}\[\]\/\# et $var./) { print; } 153if (0 || /pP \"\'\(\)\<\>\{\}\[\]\/\# et $var./) { print; } 154print or/pP \"\'\(\)\<\>\{\}\[\]\/\# et $var./; 155print if /pP \"\'\(\)\<\>\{\}\[\]\/\# et $var./; 156print unless 157 158 159 /pP \"\'\(\)\<\>\{\}\[\]\/\# et $var./; 160 161my @o = $contents =~ 162 163 164 /^(?>\S+) \s* := \s* LINKSRC \s* = \s* \S+/mxg; 165 166foreach my $v (@o) { # This loop shouldn't mistakenly be inside the previous m// 167 print $v; 168} 169 170# 171# The following table is from 172# https://perldoc.perl.org/perlop.html#Quote-and-Quote-like-Operators . 173# The samples following are generated per the table. 174# 175# Customary Generic Meaning Interpolates 176# '' q{} Literal no 177# "" qq{} Literal yes 178# `` qx{} Command yes* 179# qw{} Word list no 180# // m{} Pattern match yes* 181# qr{} Pattern yes* 182# s{}{} Substitution yes* 183# tr{}{} Transliteration no (but see below) 184# y{}{} 185# 186 187$s = 'pP \"\'\(\)\<\>\{\}\[\]\/\# et $var.'; 188$s = q{pP {{nest}}\"\'\(\)\<\>\[\]\/\# et $var.}; 189$s = q[pP [[nest]]\"\'\(\)\<\>\{\}\/\# et $var.]; 190$s = q(pP ((nest))\"\'\<\>\{\}\[\]\/\# et $var.); 191$s = q<pP <<nest>>\"\'\(\)\{\}\[\]\/\# et $var.>; 192$s = q/pP \"\'\(\)\<\>\{\}\[\]\/\# et $var./; 193$s = q zpP \"\'\(\)\<\>\{\}\[\]\/\# et $var.z; 194$s = q#pP \"\'\(\)\<\>\{\}\[\]\/\# et $var.#; 195$s = q'pP \"\'\(\)\<\>\{\}\[\]\/\# et $var.'; 196$s = q"pP \"\'\(\)\<\>\{\}\[\]\/\# et $var."; 197$s = "pP \"\'\(\)\<\>\{\}\[\]\/\# et $var."; 198$s = qq{pP {{nest}}\"\'\(\)\<\>\[\]\/\# et $var.}; 199$s = qq[pP [[nest]]\"\'\(\)\<\>\{\}\/\# et $var.]; 200$s = qq(pP ((nest))\"\'\<\>\{\}\[\]\/\# et $var.); 201$s = qq<pP <<nest>>\"\'\(\)\{\}\[\]\/\# et $var.>; 202$s = qq/pP \"\'\(\)\<\>\{\}\[\]\/\# et $var./; 203$s = qq zpP \"\'\(\)\<\>\{\}\[\]\/\# et $var.z; 204$s = qq#pP \"\'\(\)\<\>\{\}\[\]\/\# et $var.#; 205$s = qq'pP \"\'\(\)\<\>\{\}\[\]\/\# et $var.'; 206$s = qq"pP \"\'\(\)\<\>\{\}\[\]\/\# et $var."; 207$s = `pP \"\'\(\)\<\>\{\}\[\]\/\# et $var.`; 208$s = qx{pP {{nest}}\"\'\(\)\<\>\[\]\/\# et $var.}; 209$s = qx[pP [[nest]]\"\'\(\)\<\>\{\}\/\# et $var.]; 210$s = qx(pP ((nest))\"\'\<\>\{\}\[\]\/\# et $var.); 211$s = qx<pP <<nest>>\"\'\(\)\{\}\[\]\/\# et $var.>; 212$s = qx/pP \"\'\(\)\<\>\{\}\[\]\/\# et $var./; 213$s = qx zpP \"\'\(\)\<\>\{\}\[\]\/\# et $var.z; 214$s = qx#pP \"\'\(\)\<\>\{\}\[\]\/\# et $var.#; 215$s = qx'pP \"\'\(\)\<\>\{\}\[\]\/\# et $var.'; 216$s = qx"pP \"\'\(\)\<\>\{\}\[\]\/\# et $var."; 217use vars qw{$Cannot %embed &punctuation *here @except $sigils}; 218use vars qw[$Cannot %embed &punctuation *here @except $sigils]; 219use vars qw($Cannot %embed &punctuation *here @except $sigils); 220use vars qw<$Cannot %embed &punctuation *here @except $sigils>; 221use vars qw/$Cannot %embed &punctuation *here @except $sigils/; 222use vars qw z$Cannot %embed &punctuation *here @except $sigilsz; 223use vars qw#$Cannot %embed &punctuation *here @except $sigils#; 224use vars qw'$Cannot %embed &punctuation *here @except $sigils'; 225use vars qw"$Cannot %embed &punctuation *here @except $sigils"; 226$s = /pP \"\'\(\)\<\>\{\}\[\]\/\# et $var./; 227$s = m{pP {{nest}}\"\'\(\)\<\>\[\]\/\# et $var.}; 228$s = m[pP [[nest]]\"\'\(\)\<\>\{\}\/\# et $var.]; 229$s = m(pP ((nest))\"\'\<\>\{\}\[\]\/\# et $var.); 230$s = m<pP <<nest>>\"\'\(\)\{\}\[\]\/\# et $var.>; 231$s = m/pP \"\'\(\)\<\>\{\}\[\]\/\# et $var./; 232$s = m zpP \"\'\(\)\<\>\{\}\[\]\/\# et $var.z; 233$s = m#pP \"\'\(\)\<\>\{\}\[\]\/\# et $var.#; 234$s = m'pP \"\'\(\)\<\>\{\}\[\]\/\# et $var.'; 235$s = m"pP \"\'\(\)\<\>\{\}\[\]\/\# et $var."; 236$s = qr{pP {{nest}}\"\'\(\)\<\>\[\]\/\# et $var.}; 237$s = qr[pP [[nest]]\"\'\(\)\<\>\{\}\/\# et $var.]; 238$s = qr(pP ((nest))\"\'\<\>\{\}\[\]\/\# et $var.); 239$s = qr<pP <<nest>>\"\'\(\)\{\}\[\]\/\# et $var.>; 240$s = qr/pP \"\'\(\)\<\>\{\}\[\]\/\# et $var./; 241$s = qr zpP \"\'\(\)\<\>\{\}\[\]\/\# et $var.z; 242$s = qr#pP \"\'\(\)\<\>\{\}\[\]\/\# et $var.#; 243$s = qr'pP \"\'\(\)\<\>\{\}\[\]\/\# et $var.'; 244$s = qr"pP \"\'\(\)\<\>\{\}\[\]\/\# et $var."; 245$s = s{pP {{nest}}\"\'\(\)\<\>\[\]\/\# et $var. 246 }{pP {{nest}}\"\'\(\)\<\>\[\]\/\# et $var.}x; 247$s = s[pP [[nest]]\"\'\(\)\<\>\{\}\/\# et $var. 248 ][pP [[nest]]\"\'\(\)\<\>\{\}\/\# et $var.]x; 249$s = s(pP ((nest))\"\'\<\>\{\}\[\]\/\# et $var. 250 )(pP ((nest))\"\'\<\>\{\}\[\]\/\# et $var.)x; 251$s = s<pP <<nest>>\"\'\(\)\{\}\[\]\/\# et $var. 252 ><pP <<nest>>\"\'\(\)\{\}\[\]\/\# et $var.>x; 253$s = s/pP \"\'\(\)\<\>\{\}\[\]\/\# et $var./ 254 pP \"\'\(\)\<\>\{\}\[\]\/\# et $var./x; 255$s = s zpP \"\'\(\)\<\>\{\}\[\]\/\# et $var.z 256 pP \"\'\(\)\<\>\{\}\[\]\/\# et $var.zx; 257$s = s#pP \"\'\(\)\<\>\{\}\[\]\/\# et $var.# 258 pP \"\'\(\)\<\>\{\}\[\]\/\# et $var.#x; 259$s = s'pP \"\'\(\)\<\>\{\}\[\]\/\# et $var.' 260 pP \"\'\(\)\<\>\{\}\[\]\/\# et $var.'x; 261$s = s"pP \"\'\(\)\<\>\{\}\[\]\/\# et $var." 262 pP \"\'\(\)\<\>\{\}\[\]\/\# et $var."x; 263$s = tr{pP \"\'\(\)\<\>\[\]\/\# fin.}{pP \"\'\(\)\<\>\[\]\/\# fin.}; 264$s = tr[pP \"\'\(\)\<\>\{\}\/\# fin.][pP \"\'\(\)\<\>\{\}\/\# fin.]; 265$s = tr(pP \"\'\<\>\{\}\[\]\/\# fin.)(pP \"\'\<\>\{\}\[\]\/\# fin.); 266$s = tr<pP \"\'\(\)\{\}\[\]\/\# fin.><pP \"\'\(\)\{\}\[\]\/\# fin.>; 267$s = tr/pP \"\'\(\)\<\>\{\}\[\]\/\# fin./pP \"\'\(\)\<\>\{\}\[\]\/\# fin./; 268$s = tr zpP \"\'\(\)\<\>\{\}\[\]\/\# fin.zpP \"\'\(\)\<\>\{\}\[\]\/\# fin.z; 269$s = tr#pP \"\'\(\)\<\>\{\}\[\]\/\# fin.#pP \"\'\(\)\<\>\{\}\[\]\/\# fin.#; 270$s = tr'pP \"\'\(\)\<\>\{\}\[\]\/\# fin.'pP \"\'\(\)\<\>\{\}\[\]\/\# fin.'; 271$s = tr"pP \"\'\(\)\<\>\{\}\[\]\/\# fin."pP \"\'\(\)\<\>\{\}\[\]\/\# fin."; 272$s = y{pP \"\'\(\)\<\>\[\]\/\# fin.}{pP \"\'\(\)\<\>\[\]\/\# fin.}; 273$s = y[pP \"\'\(\)\<\>\{\}\/\# fin.][pP \"\'\(\)\<\>\{\}\/\# fin.]; 274$s = y(pP \"\'\<\>\{\}\[\]\/\# fin.)(pP \"\'\<\>\{\}\[\]\/\# fin.); 275$s = y<pP \"\'\(\)\{\}\[\]\/\# fin.><pP \"\'\(\)\{\}\[\]\/\# fin.>; 276$s = y/pP \"\'\(\)\<\>\{\}\[\]\/\# fin./pP \"\'\(\)\<\>\{\}\[\]\/\# fin./; 277$s = y zpP \"\'\(\)\<\>\{\}\[\]\/\# fin.zpP \"\'\(\)\<\>\{\}\[\]\/\# fin.z; 278$s = y#pP \"\'\(\)\<\>\{\}\[\]\/\# fin.#pP \"\'\(\)\<\>\{\}\[\]\/\# fin.#; 279$s = y'pP \"\'\(\)\<\>\{\}\[\]\/\# fin.'pP \"\'\(\)\<\>\{\}\[\]\/\# fin.'; 280$s = y"pP \"\'\(\)\<\>\{\}\[\]\/\# fin."pP \"\'\(\)\<\>\{\}\[\]\/\# fin."; 281 282# more sigiled identifier tests 283print "$abc\n${abc}\n", '$abc\n${abc}\n', "\n"; 284$s = $ {var}; 285$s = ${ var }; 286print qr z$abczix, "\n"; 287print $0 if $!; 288print $^V; 289print "${^GLOBAL_PHASE} is what?"; 290 291# more quote-like tests 292qr{\.[a-z]+$}i; 293 294# should back to YYINITIAL after HERE document 295print <<EOF; 296 Some text 297EOF 298/\b sentinel \b/ && print; # This should heuristically match as m// 299 300# spaced sigil 301$ svar = 1; 302 303# more quote-like tests 304s{\.[a-z]+$}{no}i; 305my $a = qr$abc$ix; 306 307# more POD tests 308=cut for no purpose 309print "1\n"; 310 311# POD odd case 312=ITEM fubar($) 313=CUT back -- not really though 314n0n{(sense] 315=cut back really 316print "1\n"; 317 318# format FORMLIST tests 319 format STDOUT = 320@<<<<<< @|||||| @>>>>>> 321# comment <args to follow> 322"left", substr($var, 0, 2), "\$right" 323 ... 324 print 325. 326print "1\n"; 327 328# some tests for syntax near "s" characters 329my $this = {}; 330if (! -s $this->{filename}) { 331 open UCFILE, "create_file -s $this->{start} -e $this->{end} |" or exit 0; 332} else { 333 open UCFILE, "$this->{filename}" or exit 0; 334} 335 336# more quote-like tests 337my $KK = "b"; 338$bref = {'b' => 5}; 339%bhash = ('b' => 6); 340{ print $bref -> {$KK} / $bhash { $KK }, "$bref->{$KK} $bhash{$KK} $b {\n"; } 341$bref->{int} = -1 * $bref->{int} / $bref->{a_rate}; # do not infer a m// 342$bref->{"int"} = -1 * $bref->{"int"} / $bref->{"a_rate"}; # do not infer a m// 343$var = qq[select t.col 344 from $table 345 where key = $k 346 and k1 = "$r->[0]->[0]" 347 and k2 = "$s->{ code }->{ v }" 348 and k3 = "$t ->[ 0 ]->{ v }" 349 and k4 = "$u ->{ k }->[ 0 ]" 350 order by value_date DESC]; 351push @$html, "<TD width=\"20%\">"; 352print "%\abc\n", %\, "abc\n"; 353# some comment 354push @arr, "'$key'=>" . 'q[' . $val . '],'; 355#qq[$var] 356 357# more HERE-document tests 358myfunc2(<< "THIS", $var, <<~'THAT', $var, <<OTHER, <<\ELSE, <<`Z`); 359Here's a $line1 360THIS 361 Here's a $line2 362 THAT 363Here's a $line3 364OTHER 365Here's a $line4 366ELSE 367Here's a $line5 368Here's a \$line6 369Z 370/\b sentinel \b/ && print; # This should heuristically match as m// 371 372# more quote-like tests 373for my $k (grep /=/, split /;/, $d, -1) { 374 print "1\n"; 375} 376 377# more format tests 378%a = ( 379 format => "%s"); 380 format= 381@<<<<<< @|||||| @>>>>>> 382"left", "middle", "right" 383. 384print "1\n"; 385print 'http://example.com'; 386