require 5.008; use DBI; DBI->require_version(1.39); use DBI::DBD; use DBI qw(:sql_types); use Encode; use bytes; our $phdfltsz = 16; our $maxbufsz = 64256; our $maxbigbufsz = 2097100; our $platform; our $copyright = "Copyright(c) 2001-2007, Presicient Corporation, USA"; our ($dechi, $declo); our $hostchars; our $debug; our $inited; our $use_arm; package DBD::Teradata; use Config; use Exporter; use DBI qw(:sql_types); use Time::Local; BEGIN { our @ISA = qw(Exporter); our @EXPORT = (); our @EXPORT_OK = qw( %td_type_code2str %td_type_str2baseprec %td_type_str2basescale %td_lob_scale @td_decszs %td_type_str2dbi %td_type_str2size %td_type_str2pack %td_type_str2stringtypes %td_type_str2binarytypes %td_type_dbi2stringtypes %td_type_dbi2str %td_activity_types %td_sqlstates @td_indicbits @td_indicmasks @td_decstrs @td_decscales @td_decfactors %td_type_dbi2preconly %td_type_dbi2hasprec %td_type_dbi2hasscale %td_type_dbi2pack %td_type_code2dbi %td_type_dbi2code %td_type_dbi2size %td_type_str2ddcodes %td_type_ddcode2str ); $platform = $ENV{TDAT_PLATFORM_CODE}; $hostchars = (ord('A') != 65) ? 64 : 127; my $netval = unpack('n', pack('s', 1234)); $platform = ($hostchars == 64) ? 3 : (($netval == 1234) ? 7 : 8) unless $platform && ($platform=~/^\d+$/); $hostchars |= 128 if ($netval == 1234); my $phsz = $ENV{TDAT_PH_SIZE}; $phdfltsz = $phsz if defined($phsz) && ($phsz=~/^\d+$/) && ($phsz > 0) && ($phsz < 1024); ($dechi, $declo) = ($platform == 7) ? (0, 1) : (1, 0); $debug = $ENV{TDAT_DBD_DEBUG} || 0; $use_arm = ($Config{archname}=~/^arm-linux/i); our $HAS_WEAKEN = eval { require Scalar::Util; Scalar::Util::weaken(my $test = \"foo"); 1; }; }; our %td_type_code2str = ( 400, 'BLOB', 404, 'DEFERRED BLOB', 408, 'BLOB LOCATOR', 416, 'CLOB', 420, 'DEFERRED CLOB', 424, 'CLOB LOCATOR', 448, 'VARCHAR', 452, 'CHAR', 456, 'LONG VARCHAR', 464, 'VARGRAPHIC', 468, 'GRAPHIC', 472, 'LONG VARGRAPHIC', 480, 'FLOAT', 484, 'DECIMAL', 496, 'INTEGER', 500, 'SMALLINT', 600, 'BIGINT', 688, 'VARBYTE', 692, 'BYTE', 696, 'LONG VARBYTE', 752, 'DATE', 756, 'BYTEINT', 760, 'TIMESTAMP', 764, 'TIME', ); our %td_type_code2dbi = ( 400, 30, 404, 30, 408, 31, 416, 40, 420, 40, 424, 41, 448, 12, 452, 1, 456, 12, 464, -9, 468, -8, 472, -10, 480, 6, 484, 3, 496, 4, 500, 5, 600, -5, 688, -3, 692, -2, 696, -3, 752, 9, 756, -6, 760, 11, 764, 10, ); our %td_type_str2baseprec = ( 'DEC', 5, 'DECIMAL', 5, 'CHAR', 1, 'VARCHAR', 1, 'BYTE', 1, 'VARBYTE', 1, 'GRAPHIC', 1, 'VARGRAPHIC', 1, 'TIMESTAMP', 6, 'TIME', 6, 'GRAPHIC', 1, 'YEAR', 2, 'MONTH', 2, 'DAY', 2, 'HOUR', 2, 'SECOND', 2, 'BLOB', 2147483648, 'CLOB', 2147483648); our %td_type_str2basescale = ( 'DEC', 0, 'DECIMAL', 0, 'YEAR', 6, 'DAY', 6, 'HOUR', 6, 'SECOND', 6); our %td_lob_scale = ( 'K', 1024, 'M', 1048576, 'G', 1073741824); our @td_decszs = (1, 1, 1, 2, 2, 4, 4, 4, 4, 4, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8); our %td_type_str2dbi = ( 'CHAR', 1, 'VARCHAR', 12, 'BYTE', -2, 'VARBYTE', -3, 'INT', 4, 'INTEGER', 4, 'SMALLINT', 5, 'BYTEINT', -6, 'FLOAT', 6, 'DEC', 3, 'DECIMAL', 3, 'DATE', 9, 'TIMESTAMP', 11, 'INTERVAL', 11, 'GRAPHIC', -2, 'VARGRAPHIC', -3, 'TIME', 10, 'INTERVAL DAY', 103, 'INTERVAL DAY TO HOUR', 108, 'INTERVAL DAY TO MINUTE', 109, 'INTERVAL DAY TO SECOND', 110, 'INTERVAL HOUR', 104, 'INTERVAL HOUR TO MINUTE', 111, 'INTERVAL HOUR TO SECOND', 112, 'INTERVAL MINUTE', 105, 'INTERVAL MINUTE TO SECOND', 113, 'INTERVAL MONTH', 102, 'INTERVAL SECOND', 106, 'INTERVAL YEAR', 101, 'INTERVAL YEAR TO MONTH', 107, 'TIMESTAMP WITH TIME ZONE', 95, 'TIME WITH TIME ZONE', 94, 'CLOB', 40, 'BLOB', 30, ); our %td_type_str2size = ( 'CHAR', 1, 'VARCHAR', 32000, 'BYTE', 1, 'VARBYTE', 32000, 'INT', 4, 'INTEGER', 4, 'SMALLINT', 2, 'BYTEINT', 1, 'FLOAT', 8, 'DEC', 4, 'DECIMAL', 4, 'DATE', 4, 'GRAPHIC', 2, 'VARGRAPHIC', 32000, 'TIME', 8, 'TIMESTAMP', 19, 'TIMESTAMP WITH TIME ZONE', 25, 'TIME WITH TIME ZONE', 14, 'INTERVAL DAY', 1, 'INTERVAL DAY TO HOUR', 4, 'INTERVAL DAY TO MINUTE', 7, 'INTERVAL DAY TO SECOND', 10, 'INTERVAL HOUR', 1, 'INTERVAL HOUR TO MINUTE', 4, 'INTERVAL HOUR TO SECOND', 7, 'INTERVAL MINUTE', 1, 'INTERVAL MINUTE TO SECOND', 4, 'INTERVAL MONTH', 1, 'INTERVAL SECOND', 1, 'INTERVAL YEAR', 1, 'INTERVAL YEAR TO MONTH', 4); our %td_type_str2pack = ( 'VARCHAR', 'S/a*', 'CHAR', 'A', 'FLOAT', 'd', 'DEC', 'a', 'DECIMAL', 'a', 'INT', 'l', 'INTEGER', 'l', 'SMALLINT', 's', 'BYTEINT', 'c', 'VARBYTE', 'S/a*', 'BYTE', 'a', 'DATE', 'l', 'TIMESTAMP', 'A', 'TIME', 'A', 'INTERVAL DAY', 'A', 'INTERVAL DAY TO HOUR', 'A', 'INTERVAL DAY TO MINUTE', 'A', 'INTERVAL DAY TO SECOND', 'A', 'INTERVAL HOUR', 'A', 'INTERVAL HOUR TO MINUTE', 'A', 'INTERVAL HOUR TO SECOND', 'A', 'INTERVAL MINUTE', 'A', 'INTERVAL MINUTE TO SECOND', 'A', 'INTERVAL MONTH', 'A', 'INTERVAL SECOND', 'A', 'INTERVAL YEAR', 'A', 'INTERVAL YEAR TO MONTH', 'A', 'TIMESTAMP WITH TIME ZONE', 'A', 'TIME WITH TIME ZONE', 'A', 'CLOB', 'Q/a*', 'BLOB', 'Q/a*', ); our %td_type_str2stringtypes = ( 'VARCHAR', 1, 'CHAR', 1, 'TIMESTAMP', 1, 'TIME', 1, 'INTERVAL DAY', 1, 'INTERVAL DAY TO HOUR', 1, 'INTERVAL DAY TO MINUTE', 1, 'INTERVAL DAY TO SECOND', 1, 'INTERVAL HOUR', 1, 'INTERVAL HOUR TO MINUTE', 1, 'INTERVAL HOUR TO SECOND', 1, 'INTERVAL MINUTE', 1, 'INTERVAL MINUTE TO SECOND', 1, 'INTERVAL MONTH', 1, 'INTERVAL SECOND', 1, 'INTERVAL YEAR', 1, 'INTERVAL YEAR TO MONTH', 1, 'TIMESTAMP WITH TIME ZONE', 1, 'TIME WITH TIME ZONE', 1, 'CLOB', 1, ); our %td_type_str2binarytypes = ( 'VARGRAPHIC', 1, 'GRAPHIC', 1, 'VARBYTE', 1, 'BYTE', 1, 'BLOB', 1, ); our %td_type_dbi2str = ( 12, 'VARCHAR', 1, 'CHAR', 6, 'FLOAT', 3, 'DECIMAL', 4, 'INTEGER', 5, 'SMALLINT', -6, 'BYTEINT', -3, 'VARBYTE', -2, 'BYTE', 9, 'DATE', 11, 'TIMESTAMP', 10, 'TIME', 103, 'INTERVAL DAY', 108, 'INTERVAL DAY TO HOUR', 109, 'INTERVAL DAY TO MINUTE', 110, 'INTERVAL DAY TO SECOND', 104, 'INTERVAL HOUR', 111, 'INTERVAL HOUR TO MINUTE', 112, 'INTERVAL HOUR TO SECOND', 105, 'INTERVAL MINUTE', 113, 'INTERVAL MINUTE TO SECOND', 102, 'INTERVAL MONTH', 106, 'INTERVAL SECOND', 101, 'INTERVAL YEAR', 107, 'INTERVAL YEAR TO MONTH', 95, 'TIMESTAMP WITH TIME ZONE', 94, 'TIME WITH TIME ZONE', ); our %td_activity_types = ( 0, 'Unknown', 1, 'Select', 2, 'Insert', 3, 'Update', 4, 'Update..RETRIEVING', 5, 'Delete', 6, 'Create Table', 7, 'Modify Table', 8, 'Create View', 9, 'Create Macro', 10, 'Drop Table', 11, 'Drop View', 12, 'Drop Macro', 13, 'Drop Index', 14, 'Rename Table', 15, 'Rename View', 16, 'Rename Macro', 17, 'Create Index', 18, 'Create Database', 19, 'Create User', 20, 'Grant', 21, 'Revoke', 22, 'Give', 23, 'Drop Database', 24, 'Modify Database', 25, 'Database', 26, 'Begin Transaction', 27, 'End Transaction', 28, 'Abort', 29, 'Null', 30, 'Execute', 31, 'Comment Set', 32, 'Comment Returning', 33, 'Echo', 34, 'Replace View', 35, 'Replace Macro', 36, 'Checkpoint', 37, 'Delete Journal', 38, 'Rollback', 39, 'Release Lock', 40, 'HUT Config', 41, 'Verify Checkpoint', 42, 'Dump Journal', 43, 'Dump', 44, 'Restore', 45, 'RollForward', 46, 'Delete Database', 47, 'internal use only', 48, 'internal use only', 49, 'Show', 50, 'Help', 51, 'Begin Loading', 52, 'Checkpoint Load', 53, 'End Loading', 54, 'Insert', 64, 'Exec MLOAD', 76, '2PC Vote Request', 77, '2PC Vote and Terminate', 78, '2PC Commit', 79, '2PC Abort', 80, '2PC Yes Vote', 83, 'Set Session Rate', 84, 'Monitor Session', 85, 'Identify Session', 86, 'Abort Session', 87, 'Set Resource Rate', 89, 'ANSI Commit Work', 91, 'Monitor Virtual Config', 92, 'Monitor Physical Config', 93, 'Monitor Virtual Summary', 94, 'Monitor Physical Summary', 95, 'Monitor Virtual Resource', 96, 'Monitor Physical Resource', 97, 'Create Trigger', 98, 'Drop Trigger', 99, 'Rename Trigger', 100, 'Replace Trigger', 101, 'Alter Trigger', 103, 'Drop Procedure', 104, 'Create Procedure', 105, 'Call', 106, 'Rename Procedure', 107, 'Replace Procedure', 108, 'Set Session Account', 110, 'Monitor SQL', 111, 'Monitor Version', 112, 'Begin DBQL', 113, 'End DBQL', 114, 'Create Role', 115, 'Drop Role', 116, 'Grant Role', 117, 'Revoke Role', 118, 'Create Profile', 119, 'Modify Profile', 120, 'Drop Profile', 121, 'Set Role', 122, 'UDF', 123, 'UDF', 124, 'UDF', 125, 'UDF', 126, 'UDF', 127, 'Merge Mixed', 128, 'Merge Update', 129, 'Merge Insert', 130, 'Alter Procedure', 131, 'TDQM Enable', 132, 'TDQM Stats', 133, 'TDQM Performance Group', ); our %td_sqlstates = qw( 2147 53018 2149 53018 2161 22012 2162 22012 2163 22012 2164 22003 2165 22003 2166 22003 2232 22003 2233 22003 2239 22003 2240 22003 2450 40001 2603 53015 2604 53015 2605 53015 2606 53015 2607 53015 2608 53015 2614 22003 2615 22003 2616 22003 2617 22003 2618 22012 2619 22012 2620 22021 2621 22012 2622 53015 2623 53015 2631 40001 2661 22000 2662 22011 2663 22011 2664 54001 2665 22007 2666 22007 2674 22003 2675 22003 2676 22012 2679 22012 2680 22023 2682 22003 2683 22003 2684 22012 2687 22012 2689 23502 2700 23700 2726 23726 2727 23727 2728 23728 2801 23505 2802 23505 2803 23505 2805 57014 2827 58004 2828 58004 2843 57014 2892 01003 2893 22001 2894 24894 2895 24895 2896 24896 2938 00000 2980 23505 3002 46000 3003 46000 3004 46000 3006 08T06 3007 08T07 3014 46000 3015 46000 3016 46000 3023 46000 3025 08T25 3026 46000 3110 00000 3111 40502 3120 58004 3121 02000 3130 57014 3504 53003 3509 54001 3513 00000 3514 00000 3515 52011 3517 52011 3518 54008 3519 52010 3520 22003 3523 42000 3524 42000 3526 52004 3527 42015 3528 22012 3529 42015 3530 42015 3532 53021 3534 52010 3535 22018 3539 52004 3540 54001 3541 57014 3543 57014 3545 42502 3554 53003 3556 54011 3560 52011 3564 44000 3568 42507 3569 56003 3574 56003 3577 57014 3580 53015 3581 53015 3582 42582 3597 54001 3604 23502 3606 52001 3609 54001 3617 42015 3622 53019 3627 42507 3628 42507 3629 54001 3637 53005 3638 57014 3639 53018 3640 53018 3641 53021 3642 53021 3643 53019 3644 53019 3653 53026 3654 53025 3656 52004 3659 53008 3660 53015 3661 57014 3662 53015 3663 53015 3669 21000 3702 54001 3704 42506 3705 54001 3710 54001 3712 54001 3714 54001 3721 24721 3731 42501 3732 0A732 3733 42514 3735 01004 3737 01004 3738 01004 3741 54001 3744 52010 3747 01003 3751 42504 3752 22003 3753 22003 3754 22003 3755 22003 3756 22012 3757 22003 3758 22003 3759 42504 3760 42503 3775 42506 3789 42514 3801 52010 3802 52004 3803 52010 3804 52010 3805 52010 3807 42000 3809 52002 3810 52003 3811 23502 3812 42000 3813 42000 3816 42505 3817 42505 3818 42505 3819 53015 3820 42505 3821 42505 3822 52002 3823 53007 3824 52004 3827 56021 3829 56021 3833 56021 3848 52006 3850 54001 3851 54001 3856 42501 3857 53015 3858 42501 3865 42501 3866 42501 3867 54001 3872 56003 3880 42501 3881 42501 3883 53003 3885 52001 3889 42514 3896 54001 3897 58004 3919 54011 3968 42968 3969 42969 3970 42970 3971 42971 3973 42973 3974 42974 3975 42975 3976 53030 3977 42977 3978 42978 3979 42979 3980 42980 3981 42981 3982 42982 3989 01001 3990 42990 3991 42991 3992 42992 3993 42993 3994 42994 3995 42995 3996 22001 3997 22019 3998 22025 3999 01999 5300 42J00 5301 42J01 5302 52009 5303 42J03 5304 42J04 5305 42J05 5306 42J06 5307 42J07 5308 42J08 5309 42J09 5310 42J10 5311 42J11 5312 42J12 5313 42J13 5314 42J14 5315 42J15 5316 44000 5317 23000 5800 01800 5801 01801 5802 01802 5803 01803 5804 01804 5805 01805 5806 01806 5807 01807 5808 01808 5809 01809 5810 01810 5811 01811 5812 01812 5813 01813 5814 01814 5815 01815 5816 01816 5817 01817 5818 01818 5819 01819 5820 01820 5821 01821 5822 01822 5823 01823 5824 01824 5825 01825 5826 01826 5827 01827 5828 01828 5829 01829 5830 01830 5831 01831 5832 01832 5833 01833 5834 01834 5835 01835 5836 01836 5837 01837 5838 01838 5839 01839 5840 01840 5841 01841 7601 20000 7610 24502 7627 21000 7631 24501 7632 02000 ); our @td_indicbits = (128, 64, 32, 16, 8, 4, 2, 1); our @td_indicmasks = (0x7F, 0xBF, 0xDF, 0xEF, 0xF7, 0xFB, 0xFD, 0xFE); our @td_decstrs = ( 'c', 'c', 'c', 's', 's', 'l', 'l', 'l', 'l', 'l'); our @td_decscales = ( 1.0, 1.0E-1, 1.0E-2, 1.0E-3, 1.0E-4, 1.0E-5, 1.0E-6, 1.0E-7, 1.0E-8, 1.0E-9, 1.0E-10, 1.0E-11, 1.0E-12, 1.0E-13, 1.0E-14, 1.0E-15, 1.0E-16, 1.0E-17, 1.0E-18); our @td_decfactors = ( 1.0, 1.0E1, 1.0E2, 1.0E3, 1.0E4, 1.0E5, 1.0E6, 1.0E7, 1.0E8, 1.0E9, 1.0E10, 1.0E11, 1.0E12, 1.0E13, 1.0E14, 1.0E15, 1.0E16, 1.0E17, 1.0E18); our %td_type_dbi2preconly = ( 1, 1, 12, 1, -1, 1, -2, 1, -3, 1, 3, 2); our %td_type_dbi2hasprec = ( 1, 1, 12, 1, -2, 1, -3, 1, 3, 1, 10, 1, 11, 1); our %td_type_dbi2hasscale = ( 3, 1, 110, 1, 112, 1, 113, 1, ); our %td_type_dbi2pack = ( 12, 'S/a*', 1, 'A', 6, 'd', 3, 'a', 4, 'l', 5, 's', -6, 'c', -3, 'S/a*', -2, 'a', -4, 'S/a*', 9, 'l', 11, 'A', 10, 'A', 103, 'A', 108, 'A', 109, 'A', 110, 'A', 104, 'A', 111, 'A', 112, 'A', 105, 'A', 113, 'A', 102, 'A', 106, 'A', 101, 'A', 107, 'A', 95, 'A', 94, 'A', ); our %td_type_dbi2size = ( 12, 32000, 1, 32000, 6, 8, 3, 8, 4, 4, 5, 2, -6, 1, -3, 32000, -2, 32000, -4, 32000, 9, 4, 11, 26, 10, 17 ); our %td_type_dbi2code = ( 30, 400, 31, 408, 40, 416, 41, 424, 12, 448, 1, 452, -1, 456, -9, 464, -8, 468, -10, 472, 6, 480, 3, 484, 4, 496, 5,500, -5, 600, -3, 688, -2, 692, -4, 696, 9, 752, -6, 756, 11,760, 10, 764, ); our %td_type_dbi2stringtypes = ( 11, 1, 10, 1, 103, 1, 108, 1, 109, 1, 110, 1, 104, 1, 111, 1, 112, 1, 105, 1, 113, 1, 102, 1, 106, 1, 101, 1, 107, 1, 95, 1, 94, 1 ); our %td_type_ddcode2str = ( ); our %td_type_str2ddcodes = ( ); use vars qw($VERSION $drh); our $VERSION = '1.52'; $drh = undef; my $installed = undef; use strict ; sub driver { return $drh if $drh; my ($class, $attr) = @_; $class .= '::dr'; $drh = DBI::_new_drh($class, { Name => 'Teradata', Version => $VERSION, Attribution => 'DBD::Teradata by Presicient Corp.' }); unless ($DBD::Teradata::installed) { DBD::Teradata::dr->install_method('tdat_FirstAvailable'); DBD::Teradata::dr->install_method('tdat_FirstAvailList'); DBD::Teradata::st->install_method('tdat_BindColArray'); DBD::Teradata::st->install_method('tdat_BindParmArray'); DBD::Teradata::st->install_method('tdat_Rewind'); DBD::Teradata::st->install_method('tdat_Realize'); DBD::Teradata::st->install_method('tdat_CharSet'); DBD::Teradata::st->install_method('tdat_Unpack'); $DBD::Teradata::installed = 1; } DBI->trace_msg("DBD::Teradata v.$VERSION loaded on $^O\n", 1); $drh->{_connections} = {}; return $drh; } sub CLONE { DBD::Teradata::impl->io_clone; undef $drh; } 1; package DBD::Teradata::dr; $DBD::Teradata::dr::imp_data_size = 0; sub connect { my ($drh, $dsn, $user, $auth, $attr) = @_; my $host = ''; my $port = 1025; $attr = {} unless defined $attr; $attr->{tdat_utility} = 'DBC/SQL' unless exists $attr->{tdat_utility}; $attr->{tdat_mode} = 'DEFAULT' unless exists $attr->{tdat_mode}; if ($dsn=~/^(\d+\.\d+\.\d+\.\d+)(:(\d+))?$/) { return $drh->DBI::set_err(-1, 'CLI does not support numeric host addresses.', '08001'); } elsif ($dsn=~/^(\w[^:]*)(:(\d+))?$/) { ($host, $port) = ($1, $3); } else { return $drh->DBI::set_err(-1, "Malformed dsn $dsn", '08001'); } $port = 1025 unless $port; my ($key, $val); while (($key, $val) = each %$attr) { if ($key eq 'tdat_mode') { return $drh->DBI::set_err(-1, "Unknown session mode $val specified.", 'S1000') unless ($val=~/^(ANSI|TERADATA|DEFAULT)$/i); } elsif ($key eq 'tdat_bufsize') { return $drh->DBI::set_err(-1, "Bad buffer size $val. Value must be between 64000 and 2097151.", 'S1000') unless ($val=~/^\d+$/); $attr->{tdat_bufsize} = 64000 unless ($val >= 64000); $attr->{tdat_bufsize} = 2097151 unless ($val < 2097152); } elsif ($key eq 'tdat_respsize') { return $drh->DBI::set_err(-1, "Bad reponse buffer size $val. Value must be between 64000 and 2097151.", 'S1000') unless ($val=~/^\d+$/); $attr->{tdat_respsize} = 64000 unless ($val >= 64000); $attr->{tdat_respsize} = 2097151 unless ($val < 2097152); } elsif ($key eq 'tdat_reqsize') { return $drh->DBI::set_err(-1, "Bad request buffer size $val. Value must be between 256 and 2097151.", 'S1000') unless ($val=~/^\d+$/); $attr->{tdat_reqsize} = 256 unless ($val >= 256); $attr->{tdat_reqsize} = 2097151 unless ($val < 2097152); } elsif ($key eq 'tdat_charset') { return $drh->DBI::set_err(-1, 'Bad character set.', 'S1000') unless ($val=~/^ASCII|UTF8|EBCDIC$/i); } elsif ($attr->{tdat_reconnect}) { return $drh->DBI::set_err(-1, 'Cannot reconnect non-SQL sessions.', 'S1000') if ($attr->{tdat_utility} ne 'DBC/SQL'); return $drh->DBI::set_err(-1, 'Invalid tdat_reconnect value: must be scalar or coderef.', 'S1000') if (ref $attr->{tdat_reconnect} ne 'CODE'); } } return $drh->DBI::set_err(-1, 'Username required for connect.', 'S1000') unless defined($user) || $attr->{tdat_passthru}; $attr->{tdat_bufsize} = $maxbufsz unless exists $attr->{tdat_bufsize}; $attr->{tdat_reqsize} = $attr->{tdat_bufsize} unless exists $attr->{tdat_reqsize}; $attr->{tdat_respsize} = $attr->{tdat_bufsize} unless exists $attr->{tdat_respsize}; my ($iobj, $err, $errstr, $state) = DBD::Teradata::impl->new($host, $port, $user, $auth, undef, $attr); return $drh->set_err($err, $errstr, $state) unless $iobj; $attr->{tdat_reqsize} = $iobj->io_set_reqsz($maxbufsz) if $attr->{tdat_reqsize} && ($attr->{tdat_reqsize} > $maxbufsz) && (($iobj->[40] < 5000000) || (($attr->{tdat_utility} ne 'DBC/SQL') && ($iobj->[40] < 6000000))); $attr->{tdat_respsize} = $iobj->io_set_respsz($maxbufsz) if $attr->{tdat_respsize} && ($attr->{tdat_respsize} > $maxbufsz) && ($iobj->[40] < 6000000); my ($outer, $dbh) = DBI::_new_dbh($drh,{ Name => $dsn, USER => $user, CURRENT_USER => $user, tdat_utility => $attr->{tdat_utility}, tdat_sessno => $iobj->[13], tdat_hostid => $iobj->[29], tdat_mode => $attr->{tdat_mode}, tdat_version => $iobj->[28], tdat_compatible => (defined($attr->{tdat_compatible}) ? $attr->{tdat_compatible} : 99.0), tdat_reconnect => $attr->{tdat_reconnect}, tdat_charset => $attr->{tdat_charset}, tdat_reqsize => $attr->{tdat_reqsize}, tdat_respsize => $attr->{tdat_respsize}, tdat_no_bigint => $attr->{tdat_no_bigint}, }); $dbh->{tdat_password} = $auth if $attr->{tdat_lsn}; $iobj->[31] = $dbh; $dbh->{tdat_uses_cli} = 1; $dbh->{tdat_versnum} = $iobj->[40]; $dbh->{_iobj} = $iobj; $dbh->{_stmts} = { }; $dbh->{_nextcursor} = 0; $dbh->{_cursors} = { }; $dbh->{_debug} = $ENV{TDAT_DBD_DEBUG}; $dbh->{_utf8} = ($attr->{tdat_charset} eq 'UTF8'); $dbh->{Active} = 1; $drh->{_connections}{($dsn . '_' . $dbh->{tdat_sessno})} = $dbh unless $attr->{tdat_passthru}; return $outer; } sub data_sources {} sub DESTROY { $_[0]->disconnect_all(); } sub disconnect_all { foreach (values %{$_[0]->{_connections}}) { $_->disconnect if defined($_); } $_[0]->{_connections} = { }; } sub FirstAvailable { my ($drh, $dbhlist, $timeout) = @_; my @sesslist = (); my %seshash; foreach my $dbh (@$dbhlist) { push(@sesslist, defined($dbh) ? (ref $dbh) ? $dbh->{_iobj} : $dbh : undef); } my @outlist = DBD::Teradata::impl::io_FirstAvailList(\@sesslist, $timeout); return (@outlist ? $outlist[0] : undef); } *tdat_FirstAvailable = \&FirstAvailable; sub FirstAvailList { my ($drh, $dbhlist, $timeout) = @_; my @sesslist = (); foreach my $dbh (@$dbhlist) { push(@sesslist, defined($dbh) ? (ref $dbh) ? $dbh->{_iobj} : $dbh : undef); } return DBD::Teradata::impl::io_FirstAvailList(\@sesslist, $timeout); } *tdat_FirstAvailList = \&FirstAvailList; 1; package DBD::Teradata::db; use DBI qw(:sql_types); $DBD::Teradata::db::imp_data_size = 0; our %readonly_attrs = qw( tdat_utility 1 tdat_sessno 1 tdat_hostid 1 tdat_mode 1 tdat_version 1 tdat_compatible 1 tdat_charset 1 ); our %valid_attrs = ( 'ChopBlanks', 1, 'tdat_sp_print', 1, 'tdat_sp_save', 1, 'tdat_compatible', 1, 'tdat_formatted', 1, 'tdat_keepresp', 1, 'tdat_nowait', 1, 'tdat_raw_in', 1, 'tdat_raw_out', 1, 'tdat_raw', 1, 'tdat_clone', 1, 'tdat_mload', 1, 'tdat_mlseq', 1, 'tdat_mlmask', 1, 'tdat_vartext_out', 1, 'tdat_vartext_in', 1, 'tdat_charset', 1, 'tdat_passthru', 1, 'tdat_no_bigint', 1, ); my $pmapi_loaded; sub table_info { my $dbh = shift; return undef unless ($dbh->{tdat_utility} eq 'DBC/SQL'); my $sth = $dbh->prepare( "SELECT NULL AS TABLE_CAT, DATABASENAME AS TABLE_SCHEM, TABLENAME AS TABLE_NAME, CASE TABLEKIND WHEN 'I' THEN 'JOIN INDEX' WHEN 'V' THEN 'VIEW' ELSE (CASE WHEN UPPER(REQUESTTEXT) LIKE '% GLOBAL TEMP% TABLE %' THEN 'GLOBAL TEMPORARY' ELSE (CASE WHEN UPPER(REQUESTTEXT) LIKE '% VOLATILE TABLE %' THEN 'VOLATILE' ELSE 'TABLE' END) END) END AS TABLE_TYPE, COMMENTSTRING (VARCHAR(256)) AS REMARKS FROM DBC.TABLESX WHERE TABLEKIND IN ('I', 'T', 'V') ORDER BY 2,3"); $sth->execute; return $sth; } sub tables { my $dbh = shift; return undef unless ($dbh->{tdat_utility} eq 'DBC/SQL'); my $sth = $dbh->prepare( "SELECT TRIM(DATABASENAME) || '.' || TRIM(TABLENAME) AS ALL_TABLES FROM DBC.TABLESX WHERE TABLEKIND IN ('I', 'T', 'V')"); $sth->execute; my @tbls = (); my $row; push(@tbls, $$row[0]) while ($row = $sth->fetchrow_arrayref); return @tbls; } sub ping { return $_[0]->{_iobj}->io_ping || $_[0]->DBI::set_err($_[0]->{_iobj}->io_get_error()); } sub prepare { my ($dbh, $stmt, $attribs) = @_; $attribs = {} unless $attribs; $attribs->{tdat_raw_in} = $attribs->{tdat_raw}, $attribs->{tdat_raw_out} = $attribs->{tdat_raw} if $attribs->{tdat_raw}; return $dbh->DBI::set_err(-1, 'Raw output mode not compatible with formatted mode.', 'S1000') if $attribs->{tdat_raw_out} && $attribs->{tdat_formatted}; return $dbh->DBI::set_err(-1, 'Raw input mode incompatible with vartext input mode.', 'S1000') if $attribs->{tdat_raw_in} && $attribs->{tdat_vartext_in}; return $dbh->DBI::set_err(-1, 'Raw output mode incompatible with vartext output mode.', 'S1000') if $attribs->{tdat_raw_out} && $attribs->{tdat_vartext_out}; my $passthru = $attribs->{tdat_passthru}; my $csth = $attribs->{tdat_clone}; return $dbh->DBI::set_err(-1, 'tdat_clone value must be DBI statement handle.', 'S1000') unless (! defined($csth)) || (((ref $csth eq 'DBI::st') || (ref $csth eq 'DBD::Teradata::Utility::st'))); foreach (keys %$attribs) { return $dbh->DBI::set_err(-1, "Unknown statement attribute \"$_\"." , 'S1000') unless $valid_attrs{$_}; return $dbh->DBI::set_err(-1, 'Invalid raw mode value.', 'S1000') if (($_ eq 'tdat_raw_in') || ($_ eq 'tdat_raw_out')) && ($attribs->{$_} ne 'RecordMode') && ($attribs->{$_} ne 'IndicatorMode'); } my $sessno = $dbh->{tdat_sessno}; my $iobj = $dbh->{_iobj}; my $partition = 1; $stmt =~s/\n/\r/g; $stmt=~s/^\s+//; $stmt=~s/\s+$//; return $dbh->DBI::set_err(-1, 'Cursor syntax only supported in ANSI mode.' , 'S1000') if ($dbh->{tdat_mode} ne 'ANSI') && ($stmt=~/\s+FOR\s+CURSOR\s*;?$/i); my $compatible = $attribs->{tdat_compatible} || $dbh->{tdat_compatible}; if ($stmt=~/^\s*HELP\s+VOLATILE\s+TABLE\s*$/i) { return _make_sth($dbh, { %$attribs, Statement => $stmt, tdat_stmt_info => [ undef, { ActivityType => 'Help', ActivityCount => 1, StartsAt => 0, EndsAt => 1, } ], NUM_OF_FIELDS => 2, NAME => [ 'Table Name', 'Table Id' ], TYPE => [ 1, 1 ], PRECISION => [ 30, 12 ], SCALE => [ undef, undef ], NULLABLE => [ undef, undef ], tdat_TYPESTR => [ 'CHAR(30)', 'CHAR(30)' ], tdat_TITLE => [ 'Table Name', 'Table Id' ], tdat_FORMAT => [ 'X(30)', 'X(12)' ], _unpackstr => [ 'A30 A12' ], NUM_OF_PARAMS => 0, } ); } elsif ($stmt=~/^ECHO\b/i) { return _make_sth($dbh, { %$attribs, Statement => $stmt, tdat_stmt_info => [ undef, { ActivityType => 'Echo', ActivityCount => 0, StartsAt => 0, EndsAt => 0, } ], NUM_OF_FIELDS => 1, NAME => [ 'ECHOTEXT' ], TYPE => [ 12 ], PRECISION => [ 255 ], SCALE => [ undef ], NULLABLE => [ 0 ], tdat_TYPESTR => [ 'VARCHAR(255)' ], tdat_TITLE => [ 'Echo Text' ], tdat_FORMAT => [ 'X(255)' ], _unpackstr => [ 'A*' ], NUM_OF_PARAMS => 0, } ); } elsif ($stmt=~/^EXPLAIN\b/i) { return _make_sth($dbh, { %$attribs, Statement => $stmt, tdat_stmt_info => [ undef, { ActivityType => 'Explain', ActivityCount => 0, StartsAt => 0, EndsAt => 0, } ], NUM_OF_FIELDS => 1, NAME => [ 'Explanation' ], TYPE => [ 12 ], PRECISION => [ 80 ], SCALE => [ undef ], NULLABLE => [ 0 ], tdat_TYPESTR => [ 'VARCHAR(80)' ], tdat_TITLE => [ 'Explanation' ], tdat_FORMAT => [ 'X(80)' ], _unpackstr => [ 'A*' ], NUM_OF_PARAMS => 0, } ); } elsif ($stmt=~/^(CREATE|REPLACE)\s+PROCEDURE\s+/i) { return _make_sth($dbh, { %$attribs, Statement => $stmt, tdat_stmt_info => [ undef, { ActivityType => 'Create Procedure', ActivityCount => 0, StartsAt => 0, EndsAt => 0, }, ], NUM_OF_FIELDS => 1, NAME => [ 'COMPILE_ERROR' ], TYPE => [ 12 ], PRECISION => [ 255 ], SCALE => [ undef ], NULLABLE => [ 0 ], tdat_TYPESTR => [ 'VARCHAR(255)' ], tdat_TITLE => [ 'Compile Error' ], tdat_FORMAT => [ 'X(255)' ], _unpackstr => [ 'S/A' ], NUM_OF_PARAMS => 0, } ); } my $rowid = undef; $rowid = $dbh->{_cursors}{uc $1}{_rowid} if ($stmt=~/\s+WHERE\s+CURRENT\s+OF\s+([^\s;]+)\s*;?\s*$/i); my $sth = $iobj->io_prepare($dbh, \&_make_sth, $stmt, $rowid, $attribs, $compatible, $passthru); return $sth || $dbh->DBI::set_err($iobj->io_get_error()); } sub _make_sth { my ($dbh, $args) = @_; delete $args->{tdat_clone}; delete $args->{tdat_passthru}; $args->{CursorName} = 'CURS' . $dbh->{_nextcursor}; $dbh->{_nextcursor}++; $args->{tdat_stmt_num} = 0; $args->{tdat_sessno} = $dbh->{tdat_sessno}; $args->{tdat_compatible} = '999.0' unless $args->{tdat_compatible}; $args->{tdat_no_bigint} = $dbh->{tdat_no_bigint} unless exists $args->{tdat_no_bigint}; $args->{ParamValues} = {} unless $args->{ParamValues}; $args->{ParamArrays} = {} unless $args->{ParamArrays}; my @sthp = (); $sthp[13] = -1; $sthp[18] = delete $args->{_packstr}; $sthp[10] = delete $args->{_unpackstr}; $sthp[11] = $dbh->{_iobj}; $sthp[5] = []; $sthp[2] = delete $args->{_ptypes}; $sthp[9] = delete $args->{_plens}; $sthp[15] = delete $args->{_usephs}; $sthp[21] = delete $args->{_usenames}; $sthp[22] = 1; $sthp[24] = 0; $sthp[4] = delete $args->{_parmdesc}; $sthp[8] = delete $args->{_parmmap}; $sthp[23] = $dbh; $args->{_p} = \@sthp; if ($args->{tdat_vartext_in}) { my ($ptypes, $plens) = ($sthp[2], $sthp[9]); foreach (0..$#$ptypes) { $dbh->set_err(0, 'Using VARTEXT input with other than VARCHAR USING parameter.', '00000'), $ptypes->[$_] = 12, $plens->[$_] = 16 unless ($ptypes->[$_] == 12); } $sthp[18] = ('S/a*' x (scalar @$ptypes)); } my $stmtinfo = $args->{tdat_stmt_info}; my ($outer, $sth) = DBI::_new_sth($dbh, { Statement => $args->{Statement}, CursorName => $args->{CursorName} }) or return $dbh->set_err(-1, 'Unable to create statement handle.', 'S1000'); $sth->STORE('NUM_OF_PARAMS', delete $args->{NUM_OF_PARAMS}); $sth->STORE('NUM_OF_FIELDS', delete $args->{NUM_OF_FIELDS}); my ($key, $val); $sth->{$key} = $val while (($key, $val) = each %$args); $dbh->{_stmts}{$sth->{CursorName}} = $sth; Scalar::Util::weaken($dbh->{_stmts}{$sth->{CursorName}}) if $DBD::Teradata::HAS_WEAKEN; $dbh->{_cursors}{$sth->{CursorName}} = $sth, $sth->{tdat_keepresp} = 1, $sthp[16] = 1 if ($#$stmtinfo == 1) && ($stmtinfo->[1]{ActivityType} eq 'Select') && ($sth->{Statement}=~/\s+FOR\s+CURSOR\s*;?\s*$/i); $dbh->{tdat_nowait} = $sth->{tdat_nowait} if ($dbh->{tdat_utility} ne 'DBC/SQL'); $sth->{tdat_TYPESTR} = DBD::Teradata::st::map_type2str($sth) unless defined $sth->{tdat_TYPESTR} || (! $sth->{NUM_OF_FIELDS}); return wantarray ? ($outer, $sth) : $outer; } sub DESTROY { my $dbh = shift; return 1 unless (defined($dbh->{tdat_sessno}) && defined($dbh->{Name}) && defined($dbh->{Driver})); my $host = $dbh->{Name} . '_' . $dbh->{tdat_sessno}; return 1 unless defined($dbh->{Driver}{_connections}{$host}); $dbh->disconnect; } sub disconnect { my $dbh = shift; my $i; $dbh->{Active} = undef; $dbh->{_stmts} = $dbh->{_cursors} = undef; return 1 unless defined($dbh->{tdat_sessno}) && defined($dbh->{Name}) && defined($dbh->{Driver}); my $sessno = $dbh->{tdat_sessno}; my $host; my $drh = $dbh->{Driver}; if ($sessno) { $host = $dbh->{Name} . '_' . $sessno; $dbh->set_err(0, 'Session not found'), return 1 unless defined($drh->{_connections}{$host}); } my $iobj = $dbh->{_iobj}; $iobj->io_disconnect unless $dbh->{_ignore_destroy}; $dbh->{_iobj} = undef; delete $drh->{_connections}{$host} if defined($host); 1; } sub commit { my $dbh = shift; my $xactmode = $dbh->{AutoCommit}; if (defined($xactmode) && ($xactmode == 1)) { warn('Commit ineffective while AutoCommit is on') if $dbh->{Warn}; return 1; } my $iobj = $dbh->{_iobj}; return 1 unless $iobj->[11]; foreach (values(%{$dbh->{_stmts}})) { $_->finish unless $_->{_p}[22] || ($_->{tdat_keepresp} && (! $_->{_p}[16])); } $iobj->io_commit; $dbh->DBI::set_err($iobj->io_get_error()); $iobj->[11] = 0; return 1; } sub rollback { my $dbh = shift; my $xactmode = $dbh->{AutoCommit}; if (defined($xactmode) && ($xactmode == 1)) { warn('Rollback ineffective while AutoCommit is on') if $dbh->{Warn}; return 1; } my $iobj = $dbh->{_iobj}; return 1 unless $iobj->[11]; foreach (values(%{$dbh->{_stmts}})) { $_->finish unless $_->{_p}[22] || ($_->{tdat_keepresp} && (! $_->{_p}[16])); } $iobj->io_rollback; $dbh->DBI::set_err($iobj->io_get_error()); $iobj->[11] = 0; return 1; } sub STORE { my ($dbh, $attr, $val) = @_; return $dbh->SUPER::STORE($attr, $val) unless ($attr eq 'AutoCommit') || ($attr =~ /^(tdat_|_)/); $dbh->{$attr} = $val; $dbh->{tdat_respsize} = $dbh->{_iobj}->io_set_respsz($val) if ($attr eq 'tdat_respsize'); $dbh->{tdat_reqsize} = $dbh->{_iobj}->io_set_reqsz($val) if ($attr eq 'tdat_reqsize'); $dbh->{_iobj}->io_update_version($val), $dbh->{tdat_versnum} = $val if ($attr eq 'tdat_versnum') && ($val < 6020000); return 1; } sub FETCH { my ($dbh, $attr) = @_; return $dbh->{_iobj}[23] if ($attr eq 'tdat_active'); return $dbh->{_iobj}[11] if ($attr eq 'tdat_inxact'); return $dbh->{$attr} if ($attr eq 'AutoCommit') || ($attr =~ /^(tdat_|_)/); return $dbh->SUPER::FETCH($attr); } sub tdat_SetDebug { $_[0]->{_iobj}[15]->cli_set_debug($_[1]); return $_[0]; } sub tdat_ProcessPrepare { my ($dbh, $flavor, $len, $parcel, $stmtno, $activity, $is_a_call) = @_; my %sthargs = ( tdat_stmt_info => [ undef ], NAME => [], TYPE => [], tdat_TYPESTR => [], PRECISION => [], SCALE => [], NULLABLE => [], tdat_TITLE => [], tdat_FORMAT => [], _unpackstr => [], _parmdesc => [ ], _parmap => { }, _parmnum => 0, _phnum => 0 ); my $nextcol = $dbh->{_iobj}->io_proc_prepinfo( $parcel, $stmtno, \%sthargs, $activity, $is_a_call, 0); return $nextcol ? { Names => $sthargs{NAME}, Types => $sthargs{tdat_TYPESTR}, Titles => $sthargs{tdat_TITLE}, Formats => $sthargs{tdat_FORMAT}, } : {}; } sub get_info { my $v = $DBD::Teradata::GetInfo::info{int($_[1])}; $v = $v->($_[0]) if ref $v eq 'CODE'; return $v; } sub type_info_all { return $DBD::Teradata::TypeInfo::type_info_all; } 1; package DBD::Teradata::st; use DBI qw(:sql_types); use Config; use DBD::Teradata qw( @td_decstrs @td_decszs @td_decscales @td_decfactors %td_type_dbi2stringtypes %td_type_dbi2pack %td_type_dbi2code @td_indicmasks @td_indicbits %td_type_dbi2str %td_type_dbi2hasprec %td_type_dbi2hasscale %td_type_dbi2size ); $DBD::Teradata::st::imp_data_size = 0; our $has_bigint; BEGIN { eval { require Math::BigInt; }; $has_bigint = 1 unless $@; } our %nullvals = ( 12, '', 1, '', 6, 0.0, 3,'', 4, 0, 5, 0, -6, 0, -3, '', -2, '', -4, '', 9, 0, 11, '', 10, '', 103, '', 108, '', 109, '', 110, '', 104, '', 111, '', 112, '', 105, '', 113, '', 102, '', 106, '', 101, '', 107, '', 95, '', 94, '' ); use constant MAX_PARM_TUPLES => 2147483648; sub cvt_dec2flt { my ($decstr, $prec, $scale) = @_; return ((unpack($td_decstrs[$prec], $decstr)) * $td_decscales[$scale]) if ($prec <= 9); my @ival = ($platform == 7) ? unpack('l L', $decstr) : unpack('L l', $decstr); return ($platform == 7) ? ((($ival[0]*(2.0**32)) + $ival[1]) * $td_decscales[$scale]) : (($ival[1]*(2.0**32)) + $ival[0]) * $td_decscales[$scale]; } sub cvt_eval_dec2bigint { my ($decstr, $prec, $scale) = @_; my $num; if ($prec <= 9) { $num = unpack($td_decstrs[$prec], $decstr); } else { my @ival = ($platform == 7) ? unpack('l L', $decstr) : unpack('L l', $decstr); eval { $num = Math::BigInt->new($ival[$dechi])->blsft(32)->badd($ival[$declo])->bstr(); }; } if ($scale) { my $sign = undef; ($sign, $num) = (1, substr($num, 1)) if (substr($num, 0, 1) eq '-'); $num = ('0' x ($scale - length($num) + 1)) . $num if (length($num) <= $scale); $num = '-' . $num if $sign; substr($num, -$scale, 0) = '.'; } return $num; } sub cvt_dec2bigint { my ($decstr, $prec, $scale) = @_; my $num; if ($prec <= 9) { $num = unpack($td_decstrs[$prec], $decstr); } else { my @ival = ($platform == 7) ? unpack('l L', $decstr) : unpack('L l', $decstr); $num = Math::BigInt->new($ival[$dechi])->blsft(32)->badd($ival[$declo])->bstr(); } if ($scale) { my $sign = undef; ($sign, $num) = (1, substr($num, 1)) if (substr($num, 0, 1) eq '-'); $num = ('0' x ($scale - length($num) + 1)) . $num if (length($num) <= $scale); $num = '-' . $num if $sign; substr($num, -$scale, 0) = '.'; } return $num; } sub cvt_flt2dec { my ($dval, $packed) = @_; my ($prec, $scale) = (($packed >> 8) & 31, $packed & 31); $dval = int($dval * $td_decfactors[$scale]); return pack($td_decstrs[$prec], $dval) if ($prec <= 9); my $ival1 = int($dval/(2**32)); $ival1-- if ($dval < 0); my $ival2 = int($dval - ($ival1*(2.0**32))); return ($platform == 7) ? pack('l L', $ival1, $ival2) : pack('L l', $ival2, $ival1); } sub cvt_eval_bigint2dec { return cvt_flt2dec(@_) if ($_[0]=~/[Ee]/); my $dval = shift; my ($prec, $scale) = (($_[0] >> 8) & 31, $_[0] & 31); my ($whole, $part) = split /\./, $dval; $part = '' unless defined($part); my $incr = ((length($part) > $scale) && (substr($part, $scale, 1) > 4)) ? (($dval < 0) ? -1 : 1) : 0; $dval = (length($part) < $scale) ? join('', $whole, $part, '0' x ($scale - length($part))) : (length($part) > $scale) ? join('', $whole, substr($part, 0, $scale)) : join('', $whole, $part); if ($incr) { eval { $dval = Math::BigInt->new($dval)->badd($incr)->bstr(); }; } return pack($td_decstrs[$prec], $dval) if ($prec <= 9); my ($ival1, $tval, $ival2, $out); eval { $ival1 = Math::BigInt->new($dval)->brsft(32); $tval = Math::BigInt->new($ival1)->blsft(32); $ival2 = Math::BigInt->new($dval)->bsub($tval); $out = ($platform == 7) ? pack('l L', $ival1->bstr(), $ival2->bstr()) : pack('L l', $ival2->bstr(), $ival1->bstr()); }; return $out; } sub cvt_bigint2dec { return cvt_flt2dec(@_) if ($_[0]=~/[Ee]/); my $dval = shift; my ($prec, $scale) = (($_[0] >> 8) & 31, $_[0] & 31); my ($whole, $part) = split /\./, $dval; $part = '' unless defined($part); my $incr = ((length($part) > $scale) && (substr($part, $scale, 1) > 4)) ? (($dval < 0) ? -1 : 1) : 0; $dval = (length($part) < $scale) ? join('', $whole, $part, '0' x ($scale - length($part))) : (length($part) > $scale) ? join('', $whole, substr($part, 0, $scale)) : join('', $whole, $part); $dval = Math::BigInt->new($dval)->badd($incr)->bstr() if $incr; return pack($td_decstrs[$prec], $dval) if ($prec <= 9); my $ival1 = Math::BigInt->new($dval)->brsft(32); my $tval = Math::BigInt->new($ival1)->blsft(32); my $ival2 = Math::BigInt->new($dval)->bsub($tval); return ($platform == 7) ? pack('l L', $ival1->bstr(), $ival2->bstr()) : pack('L l', $ival2->bstr(), $ival1->bstr()); } sub BindColArray { my ($sth, $pNum, $ary, $maxlen) = @_; return $sth->DBI::set_err(-1, 'BindColArray() requires arrayref parameter.', 'S1000') if (ref $ary ne 'ARRAY'); return $sth->DBI::set_err(-1, 'Invalid column number.', 'S1000') if ($pNum <= 0); my $sthp = $sth->{_p}; my $c = $sthp->[1]; $sthp->[1] = [ ], $c = $sthp->[1] unless $c; $$c[$pNum - 1] = $ary; if (defined($maxlen)) { my $ml = $sthp->[14]; $sthp->[14] = $maxlen unless defined($ml) && ($ml >= $maxlen); } 1; } *tdat_BindColArray = \&BindColArray; *bind_col_array = \&BindColArray; sub _split_vartext { my ($sth, $val) = @_; my $params = $sth->{_p}[5]; my $numparms = $sth->{NUM_OF_PARAMS}; my $p = (ref $val eq 'ARRAY') ? $val : (ref $val) ? [ $$val ] : [ $val ]; map { $params->[$_] = []; } 0..$numparms-1; my $plens = $sth->{_p}[9]; @$plens = (0) x $numparms; my @ps; my $notbar = ($sth->{tdat_vartext_in} eq '|') ? undef : $sth->{tdat_vartext_in}; foreach my $v (@$p) { @ps = $notbar ? split($notbar, $v) : split('\|', $v); foreach (0..$numparms-1) { push (@{$params->[$_]}, $ps[$_]); $plens->[$_] = length($ps[$_]) if defined($ps[$_]) && ($plens->[$_] < length($ps[$_])); } } map { $sth->{ParamArrays}{$_} = $sth->{ParamValues}{$_} = $params->[$_-1]; } 1..$numparms; return $params; } sub bind_param { my ($sth, $pNum, $val, $attr) = @_; my $sthp = $sth->{_p}; my $pname = $pNum; unless ($pNum=~/^\d+$/) { return $sth->DBI::set_err(-1, 'Invalid parameter name.', 'S1000') unless (substr($pNum, 0, 1) eq ':') && $sthp->[21]; my $i = 0; $pNum = uc substr($pNum, 1); $i++ while (($i <= $#{$sthp->[21]}) && ($sthp->[21][$i] ne $pNum)); return $sth->DBI::set_err(-1, 'Invalid parameter name.', 'S1000') if ($i > $#{$sthp->[21]}); $pNum = $i + 1; } return $sth->DBI::set_err(-1, 'Only parameter number 1 valid for raw or vartext mode.', 'S1000') if ($pNum != 1) && ($sth->{tdat_raw_in} || $sth->{tdat_vartext_in}); my $type = 12; my $tlen = $phdfltsz; my $usephs = $sthp->[15]; if ($usephs && defined($attr)) { if (ref $attr) { $type = $attr->{TYPE} || 12; $tlen = ($type == 3) ? ((($attr->{PRECISION} || 5) << 8) | ($attr->{SCALE} || 0)) : ($td_type_dbi2hasprec{$type} && exists $attr->{PRECISION}) ? $attr->{PRECISION} : $td_type_dbi2size{$type}; } else { $type = $attr; $tlen = ($type == 3) ? (5 << 8) : $td_type_dbi2size{$type}; } } $sth->{ParamValues}{$pNum} = $val; $sth->{ParamArrays}{$pNum} = $val; _split_vartext($sth, $val), return 1 if $sth->{tdat_vartext_in}; $sthp->[5][$pNum-1] = $val; return 1 unless $usephs; my $ptypes = $sthp->[2]; $ptypes->[$pNum-1] = $td_type_dbi2stringtypes{$type} ? 12 : $type; my $plens = $sthp->[9]; $plens->[$pNum-1] = (($type == 12) || ($type == -1) || ($type == -4) || ($type == -3)) ? (($attr && $attr->{PRECISION}) ? $tlen : (defined($val) && (! ref $val)) ? length($val) : $phdfltsz) : $tlen; 1; } *BindParamArray = \&bind_param; *tdat_BindParamArray = \&bind_param; *bind_param_array = \&bind_param; sub bind_param_status { return $_[0]->DBI::set_err(-1, 'Status argument must be arrayref.', 'S1000') unless (ref $_[1] eq 'ARRAY'); $_[0]->{_p}[3] = $_[1]; return 1; } sub cvt_arm_flt { my ($lo, $hi) = unpack('LL', pack('d', $_[0])); return unpack('d', pack('LL', $hi, $lo)); } sub bind_param_inout { my ($sth, $pNum, $val, $maxlen, $attr) = @_; my $sthp = $sth->{_p}; unless ($pNum=~/^\d+$/) { return $sth->DBI::set_err(-1, 'Invalid parameter name.', 'S1000') unless (substr($pNum, 0, 1) eq ':') && $sthp->[21]; my $i = 0; $pNum = uc substr($pNum, 1); $i++ while (($i <= $#{$sthp->[21]}) && ($sthp->[21][$i] ne $pNum)); return $sth->DBI::set_err(-1, 'Invalid parameter name.', 'S1000') if ($i > $#{$sthp->[21]}); $pNum = $i + 1; } $sth->bind_col($sthp->[8]{$pNum}+1, $val) if $sthp->[8] && defined($sthp->[8]{$pNum}); return bind_param($sth, $pNum, $val, $attr) } sub execute { return _execute_any({}, @_); } sub _execute_any { my ($attrs, $sth, @bind_values) = @_; my $sthp = $sth->{_p}; my $iobj = $sthp->[11]; $sth->finish if $sthp->[26]; delete $iobj->[1]{$sthp->[12]} if defined($sthp->[12]); my $params = $attrs->{_fetch_sub} ? undef : (scalar @bind_values) ? \@bind_values : $sthp->[5]; $params = delete $attrs->{_residual} if $attrs->{_residual}; my $numParam = $sth->{NUM_OF_PARAMS} || 0; if ($sth->{tdat_vartext_in} && ($#bind_values >= 0)) { return undef unless $sth->bind_param(1, $bind_values[0]); $params = $sthp->[5]; } my ($ptypes, $plens, $usephs) = ($sthp->[2], $sthp->[9], $sthp->[15]); my ($sessno, $dbh, $partition) = ($sth->{tdat_sessno}, $sthp->[23], $iobj->[19]); my $loading = (($partition == 5) || ($partition == 4)); my ($use_cursor, $cursnm, $cursth) = (0, '', undef); if ($sth->{Statement}=~/\s+WHERE\s+CURRENT\s+OF\s+([^\s;]+)\s*;?$/i) { $cursnm = uc $1; $cursth = $dbh->{_cursors}{$cursnm}; return $sth->DBI::set_err(-1, 'Specified cursor not defined or not updatable.', 'S1000') unless $cursth; return $sth->DBI::set_err(-1, 'Specified cursor not positioned on a valid row.', 'S1000') unless $cursth->{_p}[6]; $use_cursor = 1; } $iobj->[14] = 0, $sth->{tdat_keepresp} = 1 if ($sth->{Statement}=~/\s+FOR\s+CURSOR\s*;?$/i); my $rawmode = $sth->{tdat_raw_in}; my $modepcl = ($partition == 4) ? 104 : (($partition == 6) || ($rawmode && ($rawmode eq 'RecordMode'))) ? 3 : 68; $numParam = 0 unless ($partition != 6) || ($iobj->[6] && ($#$params >= 0)); return $sth->DBI::set_err(-1, 'Too many parameters provided.', 'S1000') if defined($params) && (@$params > $numParam); return $sth->DBI::set_err(-1, 'No parameters provided for parameterized statement.', 'S1000') unless ($numParam == 0) || defined($params) || defined($dbh->{tdat_loading}) || $attrs->{_fetch_sub}; my $stmtno = 0; my $maxparmlen = 1; if ($attrs->{_fetch_sub}) { $maxparmlen = MAX_PARM_TUPLES; } else { foreach (0..$numParam-1) { $maxparmlen = scalar(@{$$params[$_]}) if (ref $$params[$_] eq 'ARRAY') && (scalar(@{$$params[$_]}) > $maxparmlen); } } my $fldcnt = $numParam; my ($tuples, $datainfo, $indicdata) = (0, '', ''); my $pos = 0; if (($params && scalar @$params) || $attrs->{_fetch_sub}) { ($tuples, $datainfo, $indicdata) = $usephs ? _process_ph_params($sth, $fldcnt, $params, $attrs) : _process_using_params($sth, $fldcnt, $rawmode, $modepcl, $params, $attrs); return undef unless $tuples; } $iobj->io_tddo('BT'), $iobj->[11] = 1 if ($partition == 1) && (!$dbh->{AutoCommit}) && ($dbh->{tdat_mode} ne 'ANSI') && ($iobj->[11] == 0); $iobj->[11] = 1 if ($partition == 1) && ($dbh->{tdat_mode} eq 'ANSI'); return $tuples if $attrs->{_fetch_sub}; my $rowcnt = $iobj->io_execute($sth, $datainfo, $indicdata, ($use_cursor ? $cursth->{_p}[6] : undef)); $sthp->[13] = $rowcnt; return $sth->DBI::set_err($iobj->io_get_error()) unless defined($rowcnt); $sth->{Active} = ($sth->{NUM_OF_FIELDS} != 0); undef $sthp->[6] if ($sth->{Statement}=~/^DELETE\s+.+\s+WHERE\s+CURRENT\s+OF\s+\w+$/i); $sthp->[26] = 1 unless $sthp->[22] && (! $sth->{tdat_keepresp}); return ($rowcnt == 0) ? -1 : $rowcnt if ($sth->{tdat_compatible} lt '2.0'); return ($rowcnt == 0) ? '0E0' : $rowcnt; } sub _gen_datainfo { my ($fldcnt, $ptypes, $plens, $maxszs) = @_; my $packstr = ''; my $datainfo = pack('S', $fldcnt) . ("\0" x ($fldcnt * 4)); my $prec; my $j = 2; foreach (0..$fldcnt-1) { my $tdtype = $td_type_dbi2code{$ptypes->[$_]}+1; $plens->[$_] ||= 0 if ($ptypes->[$_] == 12) || ($ptypes->[$_] == -3); $prec = ($ptypes->[$_] == 3) ? $td_decszs[($plens->[$_] >> 8) & 31] : $plens->[$_]; $packstr .= (($ptypes->[$_] == -2) || ($ptypes->[$_] == 3)) ? "a$prec " : ($ptypes->[$_] == 1) ? "A$prec " : $td_type_dbi2pack{$ptypes->[$_]} . ' '; $prec = 2 + $plens->[$_] if ($maxszs->[$_] < $plens->[$_]) && (($ptypes->[$_] == 12) || ($ptypes->[$_] == -3)); substr($datainfo, $j, 4) = pack('SS', $tdtype, $plens->[$_]); $maxszs->[$_] = $prec; $j += 4; } return ($datainfo, $packstr); } sub _process_ph_params { my ($sth, $fldcnt, $params, $attrs) = @_; my $indicdata; my $pos = 0; my $maxsz = 100; my ($i, $p); my $sthp = $sth->{_p}; my $iobj = $sthp->[11]; my $ptypes = $sthp->[2]; my $plens = $sthp->[9]; my $fetch_sub = $attrs->{_fetch_sub}; my @maxszs = ((0) x $fldcnt); my ($datainfo, $packstr) = _gen_datainfo($fldcnt, $ptypes, $plens, \@maxszs); my @tmpary = (); my $ttype = 12; my @indicvec = (); my $tuples = 0; my $deccvt = ($sth->{tdat_no_bigint} || (!$has_bigint)) ? \&cvt_flt2dec : ($^O eq 'MSWin32') ? \&cvt_bigint2dec : \&cvt_eval_bigint2dec; $params = &$fetch_sub() unless $params && scalar @$params; while ($params) { @indicvec = (0xFF) x (($fldcnt & 7) ? ($fldcnt>>3) + 1 : $fldcnt>>3); $pos = 0; @tmpary = (); foreach (0..$fldcnt-1) { $ttype = $ptypes->[$_]; $p = $params->[$_]; $p = (ref $p eq 'ARRAY') ? $p->[0] : $$p if defined($p) && (ref $p); push(@tmpary, $nullvals{$ttype}), $pos += (($ttype == 12) || ($ttype == -3)) ? 2 : $maxszs[$_], next unless defined($p); $indicvec[$_>>3] &= $td_indicmasks[$_ & 7], push(@tmpary, ($ttype == 3) ? $deccvt->($p, $plens->[$_]) : (($ttype == 6) && $use_arm) ? cvt_arm_flt($p) : $p); $pos += (($ttype == 12) || ($ttype == -3)) ? 2 + length($p) : ($ttype == 3) ? $td_decszs[(($plens->[$_]>>8) & 31)] : $plens->[$_]; $maxszs[$_] = length($p) + 2, substr($datainfo, 4 + ($_ << 2), 2, pack('S', $maxszs[$_])) if (($ttype == 12) || ($ttype == -3)) && ($maxszs[$_] < length($p) + 2); } map { $maxsz += $_; } @maxszs; $maxsz += scalar @indicvec; $indicdata = "\0" x $maxsz; substr($indicdata, 0, scalar(@indicvec), pack('C*', @indicvec)); substr($indicdata, scalar(@indicvec), $pos, pack($packstr, @tmpary)); $pos += scalar(@indicvec); return (++$tuples, $datainfo, substr($indicdata, 0, $pos)) ; } substr($iobj->[16], $attrs->{_datainfop}, length($datainfo), $datainfo); return ($tuples, undef, undef); } sub _process_using_params { my ($sth, $fldcnt, $rawmode, $modepcl, $params, $attrs) = @_; my $indicdata; my $pos = 0; my $maxsz = (($fldcnt & 7) ? ($fldcnt>>3) + 1 : $fldcnt>>3); my ($i, $k, $p); my $sthp = $sth->{_p}; my $iobj = $sthp->[11]; my $ptypes = $sthp->[2]; my $plens = $sthp->[9]; my $packstr = $sthp->[18]; my $fetch_sub = $attrs->{_fetch_sub}; my $tuples = 0; my $deccvt = ($sth->{tdat_no_bigint} || (!$has_bigint)) ? \&cvt_flt2dec : ($^O eq 'MSWin32') ? \&cvt_bigint2dec : \&cvt_eval_bigint2dec; unless ($rawmode) { for ($i = 0; $i < $fldcnt; $i++) { $maxsz += (($ptypes->[$i] == 3) ? $td_decszs[(($plens->[$i]>>8) & 31)] : $plens->[$i]); $maxsz += 2 if ($ptypes->[$i] == 12) || ($ptypes->[$i] == -3); } } my @tmpary = (); my $ttype = 12; my @indicvec = (); $params = &$fetch_sub() unless $params && scalar @$params; my $is_vartext = $sth->{tdat_vartext_in}; my @ps; my $notbar = ($is_vartext && ($is_vartext eq '|')) ? undef : $is_vartext; while ($params) { if ($is_vartext && (scalar @$params == 1)) { @$params = $notbar ? split($notbar, $params->[0]) : split('\|', $params->[0]); foreach (0..$fldcnt-1) { $plens->[$_] = length($params->[$_]) if defined($params->[$_]) && ($plens->[$_] < length($params->[$_])); } } unless ($rawmode) { @indicvec = (0xFF) x (($fldcnt & 7) ? ($fldcnt>>3) + 1 : $fldcnt>>3); $pos = 0; @tmpary = (); foreach (0..$fldcnt-1) { $ttype = $ptypes->[$_]; $p = $params->[$_]; $p = (ref $p eq 'ARRAY') ? $p->[0] : $$p if defined($p) && (ref $p); push(@tmpary, $nullvals{$ttype}), $pos += (($ttype == 12) || ($ttype == -3)) ? 2 : ($ttype == 3) ? $td_decszs[($plens->[$_] >> 8) & 31] : $plens->[$_], next unless defined($p); $indicvec[$_>>3] &= $td_indicmasks[$_ & 7], push(@tmpary, ($ttype == 3) ? $deccvt->($p, $plens->[$_]) : (($ttype == 6) && $use_arm) ? cvt_arm_flt($p) : $p); $pos += (($ttype == 12) || ($ttype == -3)) ? 2 + length($p) : ($ttype == 3) ? $td_decszs[(($plens->[$_]>>8) & 31)] : $plens->[$_]; $ttype = $ptypes->[$i]; $p = $params->[$i]; $p = $$p if defined($p) && (ref $p); } $indicdata = "\0" x $maxsz; substr($indicdata, 0, scalar(@indicvec), pack('C*', @indicvec)); substr($indicdata, scalar(@indicvec), $pos, pack($packstr, @tmpary)); $pos += scalar(@indicvec); } else { $p = $params->[0]; $p = (ref $p eq 'ARRAY') ? $p->[0] : $$p if defined($p) && (ref $p); $pos = length($p) - 3; $indicdata = substr($p, 2, $pos); } return (++$tuples, undef, substr($indicdata, 0, $pos)) ; } return ($tuples, undef, undef); } sub Realize { return defined($_[0]->{_p}[11]->io_Realize($_[0])) ? 1 : $_[0]->DBI::set_err($_[0]->{_p}[11]->io_get_error()); } *tdat_Realize = \&Realize; sub tdat_Rewind { return $_[0]->{_p}[11]->io_rewind($_[0]); } sub fetch { return $_[0]->tdat_Unpack(); } sub tdat_Unpack { my ($sth, $rec, $recmode) = @_; my $sthp = $sth->{_p}; my $sessno = $sth->{tdat_sessno}; my $stmtno = $sth->{tdat_stmt_num}; my $nowait = $sth->{tdat_nowait}; my $stmtinfo = $sth->{tdat_stmt_info}; my $rawmode = $sth->{tdat_raw_out}; my $vartext = $sth->{tdat_vartext_out}; my $colary = $sthp->[1]; my $maxlen = $sthp->[14]; my $iobj = $sthp->[11]; my $data = ''; my @tmpary = (); my $ary = (defined($colary) ? ($rawmode ? $$colary[0] : \@tmpary) : undef); my $rc; if (defined($rec)) { $data = $rec; $rc = 1; } else { $rc = $iobj->io_fetch($sth, $ary, \$data); return $sth->DBI::set_err($iobj->io_get_error()) unless defined($rc); $sth->{Active} = undef unless ($rc > 0) || $sth->{tdat_more_results}; return $rc if ($rc <= 0); } my $loopcnt = $rc; my $ftypes = $sth->{TYPE}; my $fprec = $sth->{PRECISION}; my $fscale = $sth->{SCALE}; my $stmthash = $$stmtinfo[$stmtno]; my $isCall = ($stmthash->{ActivityType} eq 'Call'); my $actends = $stmthash->{EndsAt}; my $actstarts = $stmthash->{StartsAt}; my $actsumstarts = $stmthash->{SummaryStarts}; my $actsumends = $stmthash->{SummaryEnds}; my $issum = $stmthash->{IsSummary}; my $numflds = defined($issum) ? $$actsumends[$issum] - $$actsumstarts[$issum] + 1 : $actends - $actstarts + 1; my $unpackstr = $sthp->[10][ (defined($issum) ? $$actsumstarts[$issum] : $actstarts)]; my $ibytes = ((($numflds & 7) != 0) ? ($numflds>>3) + 1 : $numflds>>3); my @row; $#row = $sth->{NUM_OF_FIELDS} - 1; if ($rawmode) { return $sth->_set_fbav(\@row) if defined($colary); $data = substr($data, $ibytes) if ($rawmode eq 'RecordMode'); $row[0] = pack('S a* c', length($data), $data, 10); return $sth->_set_fbav(\@row); } my $fpos = 0; $tmpary[0] = $data unless defined($colary); my $ibit = 0; my $pos = 0; my $prec = 0; my $ftype = 0; my $indstr =''; my @indics = (); my $lastpos = 0; my $chopem = $sth->{ChopBlanks}; my $no_indics = (($stmthash->{ActivityType} eq 'Exec MLOAD') || $recmode || ($stmthash->{ActivityType} eq 'Echo') || ($iobj->[19] == 6)); if (defined($colary)) { map { @$_ = (undef) x $loopcnt; } @$colary; } my $use_arm = ($Config{archname}=~/^arm-linux/i) ? 1 : undef; my $i; my $deccvt = ($sth->{tdat_no_bigint} || (!$has_bigint)) ? \&cvt_dec2flt : ($^O eq 'MSWin32') ? \&cvt_dec2bigint : \&cvt_eval_dec2bigint; my $utf8 = $sthp->[23]{_utf8}; my $vtext = $sth->{tdat_vartext_out}; for (my $k = 0; $k < $loopcnt; $k++) { @row = $vtext ? (('') x $sth->{NUM_OF_FIELDS}) : ((undef) x $sth->{NUM_OF_FIELDS}); if (ref $data) { $data = $tmpary[$k] if defined($colary); $fpos = defined($issum) ? $$actsumstarts[$issum] : $actstarts; $lastpos = $fpos + $numflds - 1; @row[$fpos..$lastpos] = @$data; $#row = $numflds - 1 if ($#row < $numflds-1); foreach $i ($fpos..$lastpos) { next unless defined($row[$i]); $row[$i] = Encode::decode_utf8($row[$i]) if $utf8; $row[$i] =~ s/\s+$// if $chopem; next if defined($vtext); $colary->[$i][$k] = $row[$i] if $$colary[$i]; } if (defined($vtext)) { $row[0] = join($vtext, @row); $numflds--; @row[1..$numflds] = (undef) x $numflds; $numflds++; $colary->[0][$k] = $row[0] if $$colary[0]; } next; } $data = substr($tmpary[$k], 2, length($tmpary[$k]) - 3) if defined($colary); $pos = 0; $indstr = substr($data, 0, $ibytes), $data = substr($data, $ibytes) unless $no_indics; @indics = $no_indics ? (0) : unpack('C*', $indstr); $unpackstr=~tr/A/a/; $fpos = defined($issum) ? $$actsumstarts[$issum] : $actstarts; splice(@row, $fpos, $numflds, unpack($unpackstr, $data)); $#row = $sth->{NUM_OF_FIELDS} - 1 if ($#row < $sth->{NUM_OF_FIELDS}-1); for (my $i = 0; $i < $numflds; $i++, $fpos++) { my $ftype = $$ftypes[$fpos]; $row[$fpos] = ($vtext ? '' : undef), next if defined($indics[$i>>3]) && ($indics[$i>>3] & $td_indicbits[($i & 7)]); $row[$fpos] = $deccvt->($row[$fpos], $$fprec[$fpos], $$fscale[$fpos]) if ($ftype == 3); $row[$fpos] = cvt_arm_flt($row[$fpos]) if $use_arm && ($ftype == 6); if (($ftype == 1) || ($ftype == 12)) { $row[$fpos] = Encode::decode_utf8($row[$fpos]) if $utf8; $row[$fpos] =~ s/\s+$// if $chopem; } next if defined($vtext); $colary->[$i][$k] = $row[$fpos] if $$colary[$i]; } if (defined($vtext)) { $row[0] = join($vtext, @row); $numflds--; @row[1..$numflds] = (undef) x $numflds; $numflds++; $colary->[0][$k] = $row[0] if $$colary[0]; } } return $rec ? \@row : $sth->_set_fbav(\@row); } *fetchrow_arrayref = \&fetch; sub STORE { my ($sth, $attr, $val) = @_; return $sth->SUPER::STORE($attr, $val) unless ($attr=~/^(tdat)?_/) ; $sth->{$attr} = $val; return 1; } sub tdat_get_param_values { my $sth = shift; print "we got to get_param_values\n"; return undef unless $sth->{NUM_OF_PARAMS}; my $sthp = $sth->{_p}; my $numParam = $sth->{NUM_OF_PARAMS}; my $params = $sthp->[5]; my %pval = (); if ($sthp->[15]) { map { $pval{$_+1} = $params->[$_]; } (0..$numParam-1); return \%pval; } my $pnames = $sthp->[21]; map { $pval{$pnames->[$_]} = $params->[$_]; } (0..$#$pnames); return \%pval; } sub tdat_get_param_types { my $sth = shift; return undef unless $sth->{NUM_OF_PARAMS}; my $sthp = $sth->{_p}; my $numParam = $sth->{NUM_OF_PARAMS}; my $ptypes = $sthp->[2]; my $plens = $sthp->[9]; my $pnames = $sthp->[21]; my $callparms = $sthp->[4]; my $name; my %pval = (); foreach (0..$numParam-1) { $name = $pnames ? $pnames->[$_] : $_+1; $pval{$name} = { TYPE => ($ptypes->[$_] || SQL_UNKNOWN_TYPE), }; $pval{$name}->{IN_OR_OUT} = ($callparms->[$_] & 2) ? (($callparms->[$_] & 4) ? 'INOUT' : 'IN') : 'OUT' if $callparms; next unless $ptypes->[$_] && $td_type_dbi2hasprec{$ptypes->[$_]}; $pval{$name}->{PRECISION} = $plens->[$_]; $pval{$name}->{PRECISION} = ($plens->[$_] >> 8) && 0xFF, $pval{$name}->{SCALE} = $plens->[$_] & 0xFF if ($ptypes->[$_] == 3); } return \%pval; } sub FETCH { my ($sth, $attr) = @_; return ($attr eq 'tdat_param_types') ? tdat_get_param_types($sth) : $sth->{$attr} if ($attr =~ /^(tdat)?_/); return ($attr eq 'ParamTypes') ? tdat_get_param_types($sth) : $sth->SUPER::FETCH($attr); } sub rows { $_[0]->{_p}[13]; } sub finish { my $sthp = $_[0]->{_p}; my $iobj = $sthp->[11]; $iobj->io_finish($_[0]) if $iobj; $sthp->[22] = 1; $_[0]->{Active} = $sthp->[26] = undef; $sthp->[17] = undef; $sthp->[19] = -1; delete $_[0]->{tdat_more_results}; $_[0]->SUPER::finish; 1; } sub cancel { my $sthp = $_[0]->{_p}; my $iobj = $sthp->[11]; $iobj->io_cancel($_[0]) if $iobj; unless ($_[0]->{tdat_nowait}) { $sthp->[22] = 1; $_[0]->{Active} = $sthp->[26] = undef; $sthp->[17] = undef; $sthp->[19] = -1; } 1; } sub DESTROY { my ($sth) = @_; my $sthp = $sth->{_p}; my $dbh = $sthp->[23]; $sth->finish if $sthp->[26] && (! $dbh->{_ignore_destroy}); delete $dbh->{_stmts}{$sth->{CursorName}} if $sth->{CursorName}; $sthp->[23] = undef; $sthp->[11] = undef; $sthp->[17] = undef; delete $sth->{_p}; } sub tdat_CharSet { return $_[0]->{_p}[23]{tdat_charset}; } sub map_type2str { my ($sth) = @_; return undef unless $sth->{NUM_OF_FIELDS}; my $types = $sth->{TYPE}; my $precs = $sth->{PRECISION}; my $scales = $sth->{SCALE}; my @typestrs = (); foreach my $i (0..$#$types) { my $type = $td_type_dbi2str{$types->[$i]}; push (@typestrs, "DECIMAL($$precs[$i],$$scales[$i])"), next if ($types->[$i] == 3); $type=~s/\(\)([^\(]+)\(\)/\($$precs[$i]\)$1\($$scales[$i]\)/, push (@typestrs, $type), next if $td_type_dbi2hasscale{$types->[$i]}; $type .= "($$precs[$i])" if $td_type_dbi2hasprec{$types->[$i]}; push (@typestrs, $type); } return \@typestrs; } 1; package DBD::Teradata::ReqFactory; use strict; use warnings; sub new { my $class = shift; my $self = { noprepopts => pack('SSa10', 85, 14, 'RS'), prepopts => pack('SSa10', 85, 14, 'RP'), execopts => pack('SSa10', 85, 14, 'RE'), indicopts => pack('SSa10', 85, 14, 'IE'), tsrpcl => pack('SSSC', 128, 7, 1, 1) }; return bless $self, $class; } sub simpleRequest { my ($self, $iobj, $respsz) = @_; my $reqlen = 4 + length($_[3]) + 6; my $reqmsg = $iobj->io_buildtdhdr(5, $reqlen); return undef unless $reqmsg; substr($reqmsg, 52, $reqlen) = pack('SSA* SSS', 1, 4 + length($_[3]), $_[3], 4, 6, $respsz); return $reqmsg; } sub continueReq { my ($self, $iobj, $reqno, $keepresp, $respsz) = @_; my $reqmsg = $iobj->io_buildtdhdr(6, 6, $reqno); return undef unless $reqmsg; substr($reqmsg, 52, 6) = pack('SSS', ($keepresp ? 5 : 4), 6, $respsz); return $reqmsg; } sub prepareRequest { my ($self, $iobj, $rowid, $usingvars, $respsz) = @_; my $reqlen = 14 + 4 + length($_[5]) + 6; $reqlen += 4 + length($rowid) if $rowid; my $reqmsg = $iobj->io_buildtdhdr(5, $reqlen); return undef unless $reqmsg; my $reqpos = 52; substr($reqmsg, $reqpos, 14) = $usingvars ? $self->{prepopts} : $self->{noprepopts}; $reqpos += 14; substr($reqmsg, $reqpos, 4+length($_[5])) = pack('SSa*', 1, 4 + length($_[5]), $_[5]); $reqpos += 4 + length($_[5]); substr($reqmsg, $reqpos, 4 + length($rowid)) = pack('SSA*', 120, 4 + length($rowid), $rowid), $reqpos += 4 + length($rowid) if $rowid; substr($reqmsg, $reqpos, 6) = pack('SSS', 4, 6, $respsz); return $reqmsg; } sub spRequest { my ($self, $iobj, $sz, $pos, $segment, $sth, $respsz) = @_; my $reqlen = 7 + 4 + $sz + 6; $reqlen += 6 + 14 unless $pos; my $reqmsg = $iobj->io_buildtdhdr(5, $reqlen); return undef unless $reqmsg; my $bufpos = 52; substr($reqmsg, $bufpos, 7) = pack('SSSC', 128, 7, $segment, (($pos + $sz < length($sth->{Statement})) ? 0 : 1)); $bufpos += 7; substr($reqmsg, $bufpos, 14) = pack('SSa10', 85, 14, 'IE'), $bufpos += 14 unless $pos; substr($reqmsg, $bufpos, 4 + $sz) = pack('SSA*', 69, 4 + $sz, substr($sth->{Statement}, $pos, $sz)); $bufpos += 4 + $sz; substr($reqmsg, $bufpos, 6) = pack('SSAA', 129, 6, ($sth->{tdat_sp_print} ? 'Y' : 'N'), ($sth->{tdat_sp_save} ? 'Y' : 'N')), $bufpos += 6 unless $pos; substr($reqmsg, $bufpos, 6) = pack('SSS', 4, 6, $respsz); $pos += $sz; return ($reqmsg, $pos); } sub sqlRequest { my ($self, $iobj, $sth, $forCursor, $rowid, $modepcl, $keepresp, $respsz) = @_; my $reqlen = 4 + length($_[8]) + 6 + ((defined($_[9]) && length($_[9])) ? 4 + length($_[9]) : 0) + ((defined($_[10]) && length($_[10])) ? 4 + length($_[10]) : 0) + ($forCursor ? 4 + length($rowid) : 0) + ($sth->{tdat_mload} ? 14 : 0); return $iobj->io_set_error('Request length exceeds 64K limit.') if ($reqlen > 64256); my $reqmsg = $iobj->io_buildtdhdr(5, $reqlen); return undef unless $reqmsg; my $bufpos = 52; my $reqpcl = $sth->{tdat_formatted} ? 13 : $sth->{tdat_mload} ? 1 : 69; substr($reqmsg, $bufpos, 4 + length($_[8])) = pack('SSA*', $reqpcl, 4 + length($_[8]), $_[8]); $bufpos += 4 + length($_[8]); substr($reqmsg, $bufpos, 4 + length($_[9])) = pack('SSa*', 71, length($_[9]) + 4, $_[9]), $bufpos += (4 + length($_[9])) if defined($_[9]) && ($_[9] ne ''); substr($reqmsg, $bufpos, 4 + length($_[10])) = pack('SSa*', $modepcl, length($_[10]) + 4, $_[10]), $bufpos += (4 + length($_[10])) if defined($_[10]) && ($_[10] ne ''); substr($reqmsg, $bufpos, 4 + length($rowid)) = pack('SSa*', 120, length($rowid) + 4, $rowid) , $bufpos += (4 + length($rowid)) if $rowid; substr($reqmsg, $bufpos, 6) = pack('SSS', (($keepresp) ? 5 : 4), 6, ($sth->{tdat_mload} ? 4096 : $respsz)); return $reqmsg; } sub finishRequest { my ($self, $iobj, $kind, $reqno) = @_; my $reqmsg = $iobj->io_buildtdhdr($kind, 4, $reqno); return undef unless $reqmsg; substr($reqmsg, 52, 4) = pack('SS', ($kind == 7) ? 6 : 7, 4); return $reqmsg; } sub rewindRequest { my ($self, $iobj, $reqno, $respsz) = @_; my $reqmsg = $iobj->io_buildtdhdr(6, 10, $reqno); return undef unless $reqmsg; $respsz = 64256 if ($respsz > 64256); substr($reqmsg, 52, 10) = pack('SS SSS', 31, 4, 5, 6, $respsz); return $reqmsg; } 1; package DBD::Teradata::APHReqFactory; use base('DBD::Teradata::ReqFactory'); use strict; use warnings; sub new { my $class = shift; my $self = { noprepopts => pack('SSLa10', 85 | 0x8000, 0, 18, 'RS'), prepopts => pack('SSLa10', 85 | 0x8000, 0, 18, 'RP'), execopts => pack('SSLa10', 85 | 0x8000, 0, 18, 'RE'), indicopts => pack('SSLa10', 85 | 0x8000, 0, 18, 'IE'), tsrpcl => pack('SSLSC', 128 | 0x8000, 0, 11, 1, 1) }; return bless $self, $class; } sub simpleRequest { my ($self, $iobj, $respsz) = @_; my $reqlen = 8 + length($_[3]) + 10; my $reqmsg = $iobj->io_buildtdhdr(5, $reqlen); return undef unless $reqmsg; substr($reqmsg, 52, $reqlen) = pack('SSLA* SSLS', 1 | 0x8000, 0, 8 + length($_[3]), $_[3], 4 | 0x8000, 0, 10, $respsz); return $reqmsg; } sub continueReq { my ($self, $iobj, $reqno, $keepresp, $respsz) = @_; my $reqmsg = $iobj->io_buildtdhdr(6, 10, $reqno); return undef unless $reqmsg; substr($reqmsg, 52, 10) = pack('SSLS', ($keepresp ? 5 : 4) | 0x8000, 0, 10, $respsz); return $reqmsg; } sub prepareRequest { my ($self, $iobj, $rowid, $usingvars, $respsz) = @_; my $reqlen = 18 + 8 + length($_[5]) + 10; $reqlen += 8 + length($rowid) if $rowid; my $reqmsg = $iobj->io_buildtdhdr(5, $reqlen); return undef unless $reqmsg; my $reqpos = 52; substr($reqmsg, $reqpos, 18) = $usingvars ? $self->{prepopts} : $self->{noprepopts}; $reqpos += 18; substr($reqmsg, $reqpos, 8+length($_[5])) = pack('SSLa*', 1 | 0x8000, 0, 8 + length($_[5]), $_[5]); $reqpos += 8 + length($_[5]); substr($reqmsg, $reqpos, 8 + length($rowid)) = pack('SSLA*', 120 | 0x8000, 0, 8 + length($rowid), $rowid), $reqpos += 8 + length($rowid) if $rowid; substr($reqmsg, $reqpos, 10) = pack('SSLS', 4 | 0x8000, 0, 10, $respsz); return $reqmsg; } sub sqlRequest { my ($self, $iobj, $sth, $forCursor, $rowid, $modepcl, $keepresp, $respsz) = @_; my $reqlen = 8 + length($_[8]) + 10 + ((defined($_[9]) && length($_[9])) ? 8 + length($_[9]) : 0) + ((defined($_[10]) && length($_[10])) ? 8 + length($_[10]) : 0) + ($forCursor ? 8 + length($rowid) : 0) + ($sth->{tdat_mload} ? 18 : 0); my $reqmsg = $iobj->io_buildtdhdr(5, $reqlen); return undef unless $reqmsg; my $bufpos = 52; my $reqpcl = $sth->{tdat_formatted} ? 13 : $sth->{tdat_mload} ? 1 : 69; substr($reqmsg, $bufpos, 8 + length($_[8])) = pack('SSLA*', $reqpcl | 0x8000, 0, 8 + length($_[8]), $_[8]); $bufpos += 8 + length($_[8]); substr($reqmsg, $bufpos, 8 + length($_[9])) = pack('SSLa*', 71 | 0x8000, 0, length($_[9]) + 8, $_[9]), $bufpos += (8 + length($_[9])) if defined($_[9]) && ($_[9] ne ''); substr($reqmsg, $bufpos, 8 + length($_[10])) = pack('SSLa*', $modepcl | 0x8000, 0, length($_[10]) + 8, $_[10]), $bufpos += (8 + length($_[10])) if defined($_[10]) && ($_[10] ne ''); substr($reqmsg, $bufpos, 8 + length($rowid)) = pack('SSLa*', 120 | 0x8000, 0, length($rowid) + 8, $rowid) , $bufpos += (8 + length($rowid)) if $rowid; substr($reqmsg, $bufpos, 10) = pack('SSLS', (($keepresp) ? 5 : 4) | 0x8000, 0, 10, ($sth->{tdat_mload} ? 4096 : $respsz)); return $reqmsg; } sub finishRequest { my ($self, $iobj, $kind, $reqno) = @_; my $reqmsg = $iobj->io_buildtdhdr($kind, 8, $reqno); return undef unless $reqmsg; substr($reqmsg, 52, 8) = pack('SSL', 0x8000 | (($kind == 7) ? 6 : 7), 0, 8); return $reqmsg; } sub rewindRequest { my ($self, $iobj, $reqno, $respsz) = @_; my $reqmsg = $iobj->io_buildtdhdr(6, 18, $reqno); return undef unless $reqmsg; substr($reqmsg, 52, 18) = pack('SSL SSLS', 31 | 0x8000, 0, 8, 5 | 0x8000, 0, 10, $respsz); return $reqmsg; } 1; package DBD::Teradata::BigAPHReqFactory; use base('DBD::Teradata::APHReqFactory'); use strict; use warnings; sub continueReq { my ($self, $iobj, $reqno, $keepresp, $respsz) = @_; my $reqmsg = $iobj->io_buildtdhdr(6, 12, $reqno); return undef unless $reqmsg; substr($reqmsg, 52, 12) = pack('SSLL', ($keepresp ? 154 : 153) | 0x8000, 0, 12, $respsz); return $reqmsg; } sub prepareRequest { my ($self, $iobj, $rowid, $usingvars, $respsz) = @_; my $reqlen = 18 + 8 + length($_[5]) + 12; $reqlen += 8 + length($rowid) if $rowid; my $reqmsg = $iobj->io_buildtdhdr(5, $reqlen); return undef unless $reqmsg; my $reqpos = 52; substr($reqmsg, $reqpos, 18) = ($usingvars) ? $self->{prepopts} : $self->{noprepopts}; $reqpos += 18; substr($reqmsg, $reqpos, 8+length($_[5])) = pack('SSLa*', 1 | 0x8000, 0, 8 + length($_[5]), $_[5]); $reqpos += 8 + length($_[5]); substr($reqmsg, $reqpos, 8 + length($rowid)) = pack('SSLA*', 120 | 0x8000, 0, 8 + length($rowid), $rowid), $reqpos += 8 + length($rowid) if $rowid; substr($reqmsg, $reqpos, 12) = pack('SSLL', 153 | 0x8000, 0, 12, $respsz); return $reqmsg; } sub sqlRequest { my ($self, $iobj, $sth, $forCursor, $rowid, $modepcl, $keepresp, $respsz) = @_; my $reqlen = 8 + length($_[8]) + 12 + ((defined($_[9]) && length($_[9])) ? 8 + length($_[9]) : 0) + ((defined($_[10]) && length($_[10])) ? 8 + length($_[10]) : 0) + ($forCursor ? 8 + length($rowid) : 0) + ($sth->{tdat_mload} ? 18 : 0); my $reqmsg = $iobj->io_buildtdhdr(5, $reqlen); return undef unless $reqmsg; my $bufpos = 52; my $reqpcl = $sth->{tdat_formatted} ? 13 : $sth->{tdat_mload} ? 1 : 69; substr($reqmsg, $bufpos, 8 + length($_[8])) = pack('SSLA*', $reqpcl | 0x8000, 0, 8 + length($_[8]), $_[8]); $bufpos += 8 + length($_[8]); substr($reqmsg, $bufpos, 8 + length($_[9])) = pack('SSLa*', 71 | 0x8000, 0, length($_[9]) + 8, $_[9]), $bufpos += (8 + length($_[9])) if defined($_[9]) && ($_[9] ne ''); substr($reqmsg, $bufpos, 8 + length($_[10])) = pack('SSLa*', $modepcl | 0x8000, 0, length($_[10]) + 8, $_[10]), $bufpos += (8 + length($_[10])) if defined($_[10]) && ($_[10] ne ''); substr($reqmsg, $bufpos, 8 + length($rowid)) = pack('SSLa*', 120 | 0x8000, 0, length($rowid) + 8, $rowid) , $bufpos += (8 + length($rowid)) if $rowid; substr($reqmsg, $bufpos, 12) = pack('SSLL', (($keepresp) ? 154 : 153) | 0x8000, 0, 12, ($sth->{tdat_mload} ? 4096 : $respsz)); return $reqmsg; } sub rewindRequest { my ($self, $iobj, $reqno, $respsz) = @_; my $reqmsg = $iobj->io_buildtdhdr(6, 20, $reqno); return undef unless $reqmsg; substr($reqmsg, 52, 20) = pack('SSL SSLL', 31 | 0x8000, 0, 8, 154 | 0x8000, 0, 12, $respsz); return $reqmsg; } 1; package DBD::Teradata::impl; use IO::Socket; use Socket; use DBI qw(:sql_types); use Time::HiRes qw(time sleep); use DBD::Teradata qw( %td_type_code2str %td_type_str2baseprec %td_type_str2basescale %td_lob_scale @td_decszs %td_type_str2dbi %td_type_str2size %td_type_str2pack %td_type_str2stringtypes %td_type_str2binarytypes %td_type_dbi2stringtypes %td_type_dbi2str %td_activity_types %td_sqlstates @td_indicbits @td_indicmasks @td_decstrs @td_decscales @td_decfactors %td_type_dbi2preconly %td_type_dbi2hasprec %td_type_dbi2hasscale %td_type_dbi2pack %td_type_code2dbi %td_type_dbi2code ); use strict; use warnings; my %stmt_abbrv = ( 'INS', 'Insert', 'UPD','Update', 'DEL','Delete', 'CT','Create Table', 'CV','Create View', 'CD','Create Database' ); my %rawmodes = ( 'RecordMode', 3, 'IndicatorMode', 68); my $req_template = "\3\1" . ("\0" x 50); my %hostcache = (); my $has_cli = 1; sub new { my ($class, $host, $port, $user, $auth, $dbname, $attrs) = @_; my $obj = [ ]; bless $obj, $class; $obj->io_init; $obj->[9] = $hostchars; $obj->[3] = $attrs->{tdat_respsize}; $obj->[39] = $attrs->{tdat_reqsize}; return (undef, $obj->[18], $obj->[17], $obj->[24]) unless $obj->io_connect($host, $port, $user, $auth, $dbname, $attrs); return ($obj, 0, '', ''); } sub _getPclHeader { my ($f, $l) = unpack('SS', substr($_[0], $_[1], 4)); return ($f & 0x8000) ? ($f & 0x00FF, unpack('L', substr($_[0], $_[1]+4, 4)), 8) : ($f, $l, 4); } sub io_init { my $obj = shift; $obj->[13] = 0; $obj->[2] = 0; $obj->[4] = 0; $obj->[5] = 0; $obj->[20] = undef; $obj->[3] = undef; $obj->[23] = 0; $obj->[15] = undef; $obj->[16] = undef; $obj->[32] = undef; $obj->[14] = 1; $obj->[1] = { }; unless ($inited) { $debug = $ENV{TDAT_DBD_DEBUG} || 0; if ($debug) { eval { require DBD::Teradata::Diagnostic; import DBD::Teradata::Diagnostic qw(io_hexdump io_hdrdump io_pcldump); }; } DBI->trace_msg( "DBD::Teradata init: platform = $platform, debug = $debug, charset = $hostchars, ph size = $phdfltsz, response buf size = $maxbufsz\n", 1); substr($req_template, 5, 1) = pack('C', $platform); substr($req_template, 37, 1) = pack('C', $hostchars); $inited = 1; } srand(time); return 1; } sub io_get_error { return ($_[0]->[18], $_[0]->[17], $_[0]->[24]); } sub io_set_error { my $obj = shift; ($obj->[18], $obj->[17], $obj->[24]) = ($#_ == 2) ? @_ : ($#_ == 1) ? (@_, (($_[0] > 999) ? (exists $td_sqlstates{$_[0]} ? $td_sqlstates{$_[0]} : "T$_[0]") : 'S1000')) : (-1, $_[0], 'S1000'); return undef; } sub io_buildtdhdr { my ($obj, $kind, $len, $reqno) = @_; return $obj->io_set_error('Large requests not supported prior to V2R5.0') if (($kind == 5) || ($kind == 6)) && ($len > 65535) && ($obj->[40] < 5000000); my $charset = ($kind == 1) ? 0 : $obj->[9]; my $hostbyte = ($kind == 9) ? 1 : $platform; $obj->[2] = 0 if ($kind == 3); $obj->[2]++ if ($kind == 5) || ($kind == 8); my $reqmsg; if ($_[4]) { $obj->io_init_reqbuf($reqno, $len, $kind, $hostbyte, $charset, $_[4]); } else { $len += 52; $reqmsg = pack("a$len", ''); $len -= 52; $obj->io_init_reqbuf($reqno, $len, $kind, $hostbyte, $charset, $reqmsg); } return $reqmsg || 1 if ($kind == 10) || ($kind == 9); if ($obj->[4] == 0xffffffff) { $obj->[5]++; $obj->[4] = 0; } else { $obj->[4]++; } return $reqmsg || 1; } sub io_init_reqbuf { my ($obj, $reqno, $len, $kind, $hostbyte, $charset) = @_; substr($_[6], 0, 52) = $req_template; substr($_[6], 2, 1) = pack('C', $kind); if ($len > 65535) { substr($_[6], 4, 1) = pack('C', ($len >> 16) & 255); substr($_[6], 8, 2) = pack('n', $len & 65535); } else { substr($_[6], 8, 2) = pack('n', $len); } substr($_[6], 5, 1) = pack('C', $hostbyte); substr($_[6], 27, 11) = pack('CL N C C', 0, 1, 0, 0, 0), return 1 if ($kind == 10); substr($_[6], 20, 4) = pack('N', $obj->[13]); substr($_[6], 27, 11) = pack('CN N C C', $obj->[5], $obj->[4], ((($kind == 6) || ($kind == 7)) ? $reqno : $obj->[2]), 0, $charset); return 1; } sub io_clisend { my $obj = shift; my ($reqid, $err, $errstr) = $obj->[15]->cli_send_request(@_, $obj->[3]); DBI->trace_msg("Can't send: $!\n", 1), $obj->[15]->cli_disconnect, return $obj->io_set_error($err, $errstr, '08C01') if $err; $obj->[23] = $reqid; return $_[0]; } sub io_set_respsz { my $max = (($_[0]->[19] == 1) && ($_[0]->[40] >= 6000000)) ? 2097152 : 64256; $_[0]->[3] = $_[1] if ($_[1]=~/^\d+$/) && ($_[1] >= 64000) && ($_[1] < $max); return $_[0]->[3]; } sub io_set_reqsz { my $max = (($_[0]->[40] >= 6000000) || (($_[0]->[19] == 1) && ($_[0]->[40] >= 5000000))) ? 2097152 : 64256; $_[0]->[39] = $_[1] if ($_[1]=~/^\d+$/) && ($_[1] >= 256) && ($_[1] < $max); return $_[0]->[39]; } sub io_update_version { my ($obj, $versnum) = @_; $obj->[38] = ($versnum < 5000000) ? DBD::Teradata::ReqFactory->new() : ($versnum < 6010000) ? DBD::Teradata::APHReqFactory->new() : DBD::Teradata::BigAPHReqFactory->new() if ($obj->[19] == 1); $obj->[40] = $versnum; return $obj if ($versnum >= 6000000); $obj->[39] = 64256 if ($obj->[39] > 64256); $obj->[3] = 64256 if ($obj->[3] > 64256); } sub io_tdsend { my ($obj, $msg, $encrypt, $keepresp) = @_; my $n = 0; if ($debug) { DBI->trace_msg("Sending request\n", 2); DBI->trace_msg(io_hdrdump('Request msg header', substr($msg, 0, 52)), 1); DBI->trace_msg(io_pcldump( substr($msg, 52), length($msg) - 52), 1); } if ($obj->[34] && $encrypt) { $msg = $obj->[34]->encrypt_request($msg); DBI->trace_msg(io_hdrdump('(Encrypted) Request msg header', substr($msg, 0, 52)), 1), DBI->trace_msg(io_pcldump( substr($msg, 52), length($msg) - 52, 1), 1) if $debug; } my $kind = unpack('C', substr($msg, 2, 1)); if (($kind != 7) && ($kind != 9) && $obj->[23]) { my $rspmsg = ''; return undef unless $obj->io_getcliresp; $obj->[14] = 0; } return $obj->io_clisend(length($msg), $keepresp, $msg) ; } sub io_quicksend { my $obj = shift; my ($len, $keepresp) = @_; my $n = 0; if ($debug) { DBI->trace_msg("Sending request\n", 2); DBI->trace_msg(io_hdrdump('Request msg header', substr($_[2], 0, 52)), 1); DBI->trace_msg(io_pcldump(substr($_[2], 52), $len - 52), 1); } if ($obj->[23]) { return undef unless $obj->io_getcliresp; $obj->[14] = 0; } return $obj->io_clisend(@_) ; } sub io_getcliresp { my ($obj, $sth) = @_; my $hdr = ''; my $reqno = $obj->[23]; my ($err, $errstr) = $obj->[15]->cli_get_response(\$hdr, $reqno, (defined($sth) && $sth->{tdat_keepresp}), -1); DBI->trace_msg($errstr), $obj->[15]->cli_disconnect, return $obj->io_set_error($err, $errstr, '08S01') if $err; DBI->trace_msg("<*** CLI Response for Request $reqno ***>\n"), DBI->trace_msg(io_pcldump( substr($hdr, 52), length($hdr) - 52), 1) if $debug; $obj->[23] = 0; return $obj->io_scan_response(\$hdr, $reqno); } sub io_scan_response { my ($obj, $hdr, $reqno) = @_; my $sth = ($obj->[1]) ? $obj->[1]{$reqno} : undef; my $islastresp; my $isfailed; my $pos = 52; my $rsplen = length($$hdr); while ($pos < $rsplen) { my ($f, $l, $pclhdrsz) = _getPclHeader($$hdr, $pos); $pos += $l; $islastresp = 1, last if ($f == 12); $isfailed = 1 if ($f == 9); } if ($sth) { my $sthp = $sth->{_p}; $sthp->[22] = $islastresp || ($isfailed && ($obj->[10] ne 'ANSI')); $sthp->[24] = $isfailed; if ((! $sthp->[17]) || ($sthp->[19] >= length($sthp->[17]))) { $sthp->[17] = $hdr; $sthp->[19] = 52; } else { ${$sthp->[17]} .= substr($$hdr, 52); } } my ($f, $l, $pclhdrsz) = _getPclHeader($$hdr, 52); if (($f == 9) || ($f == 49)) { my ($tderr, $tdelen) = unpack('SS', substr($$hdr, 52+$pclhdrsz+4, 4)); my $tdemsg = substr($$hdr, 52+$pclhdrsz+8, $tdelen); DBI->trace_msg("ERROR\: $tdemsg\n", 2); $obj->io_set_error($tderr, $tdemsg); $islastresp = ($f == 9); } $obj->[15]->cli_end_request($reqno) if ($islastresp || $isfailed) && (! $obj->[31]{tdat_keepresp}) ; return $hdr; } sub io_ping { my $reqmsg = $req_template . "\0\0\0\0"; substr($reqmsg, 2, 1) = pack('C', 9); substr($reqmsg, 9, 1) = "\4"; substr($reqmsg, 52, 4) = pack('SS', 32, 4); return $_[0]->io_tdsend($reqmsg); } sub io_tddo { my ($obj, $dbreq, $dbdata, $outrecs) = @_; $obj->[18] = undef; my $reqmsg = $obj->[38]->simpleRequest($obj, $obj->[3], $dbreq); return undef unless $reqmsg; $obj->io_tdsend($reqmsg) or return undef; my $rspmsg = $obj->io_getcliresp; return undef unless $rspmsg; my ($f, $l, $pclhdrsz) = _getPclHeader($$rspmsg, 52); my $pos = 52 + $pclhdrsz; $obj->[11] = 0 if ($obj->[10] ne 'ANSI') && ($f == 9); return undef if ($f != 8) || ($l < 4); my ($stmtno, $rowcnt, $warncode, $fldcount, $activity, $warnlen) = unpack('SLSSSS', substr($$rspmsg, $pos, 14)); $obj->io_set_error($warncode, substr($$rspmsg, $pos + 14, $warnlen)) if $warnlen; $pos += ($l - $pclhdrsz); ($f, $l, $pclhdrsz) = _getPclHeader($$rspmsg, $pos); push(@$outrecs, substr($$rspmsg, $pos+$pclhdrsz, $l-$pclhdrsz)), $pos += $l, ($f, $l, $pclhdrsz) = _getPclHeader($$rspmsg, $pos) while (($f == 10) && $outrecs); DBI->trace_msg("Session $obj->[13] executed $dbreq\n", 1) if $debug; return $rowcnt; } sub io_tdcontinue { my ($obj, $sth, $nowait) = @_; my $rspmsg; my ($err, $errstr) = $obj->[15]->cli_get_response(\$rspmsg, $sth->{_p}[12], $sth->{tdat_keepresp}, -1); return $obj->io_set_error($err, $errstr) if $err; return \$rspmsg; } sub io_socket { my ($obj, $dbsys, $port) = @_; my ($inetaddr, $dest, $connfd); my $tsys = uc $dbsys; $tsys=~s/cop\d+$//i; $inetaddr = inet_aton($tsys); unless ($hostcache{$tsys}) { my $maxcop; my $host; foreach $host (keys %ENV) { $maxcop = $ENV{$host}, last if (uc $host eq $tsys); } $maxcop = 1 unless $maxcop; $hostcache{$tsys} = $maxcop; } my $cop = ($hostcache{$tsys} == 1) ? 1 : int(rand($hostcache{$tsys})) + 1; $inetaddr = inet_aton($tsys . 'COP' . $cop); return $obj->io_set_error(-1, 'Unable to get host address.', '08001') unless $inetaddr; $dest = sockaddr_in($port, $inetaddr); return $obj->io_set_error(-1, 'Unable to get host address.', '08001') unless $dest; return $obj->io_set_error(-1, "Unable to allocate a socket: $!.", '08001') unless socket($connfd, PF_INET, SOCK_STREAM, getprotobyname('tcp')); close($connfd), return $obj->io_set_error(-1, "Unable to connect: $!", '08001') unless connect($connfd, $dest); setsockopt($connfd, SOL_SOCKET, SO_KEEPALIVE, pack('l', 1)); $obj->[15] = $connfd; return $connfd; } sub io_getconfig { my ($obj, $dbsys, $port, $attr) = @_; $obj->[18] = -1; $obj->[24] = 'S1000'; $obj->[17] = ''; my $c; my $r = 3; $r-- until ($r == 0) || ($c = $obj->io_socket($dbsys, $port)); return undef unless $c; $obj->[4] = int(rand(time()))+1; $obj->[5] = 0; $obj->[40] = 0; my $cfgpos = 52; my $cfgreq = $obj->io_buildtdhdr(10, 0); if ($debug) { DBI->trace_msg("Sending request\n", 2); DBI->trace_msg(io_hdrdump('Request msg header', substr($_[2], 0, 52)), 1); } my $n = send($c, $cfgreq, 0); DBI->trace_msg("Can't send: $!\n", 1), close($c), return $obj->io_set_error(-1, 'System error: unable to send', '08C01') unless defined($n); DBI->trace_msg("Only sent $n bytes!\n", 1), close($c), return $obj->io_set_error(-1, 'System error: unable to send', '08C01') if ($n != 52); DBI->trace_msg("Request sent\n", 2) if $debug; my $rspmsg = ''; my $hdrlen = 0; my $rsplen = 8192; my $hdr = ''; DBI->trace_msg("Rcving Header\n", 2) if $debug; while ($hdrlen < 52) { unless (recv($c, $rspmsg, $rsplen, 0)) { DBI->trace_msg( "System error: can't recv msg header $!;\n rcvd $hdrlen bytes.\n", 2), close($c), return $obj->io_set_error(-1, "System error: can't recv msg header $!; closing connection.", '08S01') unless defined($rspmsg) && ($rspmsg ne ''); } $hdr .= $rspmsg; $hdrlen += length($rspmsg); } DBI->trace_msg(io_hdrdump('Response msg header', substr($hdr, 0, 52)), 1) if $debug; my ($tdver, $tdclass, $tdkind, $tdenc, $tdchksum, $tdbytevar, $tdwordvar, $tdmsglen) = unpack('C6Sn', $hdr); DBI->trace_msg("Invalid response message header; closing connection.", 2), close($c), return $obj->io_set_error(-1, 'Invalid response message header; closing connection.', '08S01') if ($tdver != 3) || ($tdclass != 2); $tdmsglen -= ($hdrlen - 52) if ($hdrlen > 52); $hdr .= "\0" x $tdmsglen if ($tdmsglen > 0); my $lrspmsg = 0; while ($tdmsglen > 0) { unless (recv($c, $rspmsg, $tdmsglen, 0)) { $hdrlen = length($rspmsg), DBI->trace_msg( "System error: can't recv msg body$!;\n rcvd $hdrlen bytes.\n", 2), close($c), return $obj->io_set_error(-1, "System error: can't recv() msg body; closing connection.", '08S01') unless defined($rspmsg) && length($rspmsg); } $lrspmsg = length($rspmsg); DBI->trace_msg("GOT $lrspmsg BYTES, NEEDED $tdmsglen\n",2) if $debug && ($lrspmsg < $tdmsglen); substr($hdr, $hdrlen, length($rspmsg)) = $rspmsg; $tdmsglen -= $lrspmsg; $hdrlen += $lrspmsg; } close($c); DBI->trace_msg(io_pcldump(substr($hdr, 52), length($hdr) - 52, 0), 1) if $debug; my ($f, $l) = unpack('SS', substr($hdr, $cfgpos)); return $obj->io_set_error(-1, "Unknown response parcel $f recv'd during CONFIG; closing connection.", '08C01') if ($f != 43) || ($l < 4); $cfgpos += 14; my $pe_cnt = unpack('S', substr($hdr, $cfgpos)); $cfgpos += 2 + ($pe_cnt * 4); my $amp_cnt = unpack('S', substr($hdr, $cfgpos)); $cfgpos += 2 + ($amp_cnt * 2); my $dflt_charset = unpack('C', substr($hdr, $cfgpos)); $cfgpos += 2; my $charset_cnt = unpack('S', substr($hdr, $cfgpos)); $cfgpos += 2 + ($charset_cnt * 32) + 6; my $defmode = unpack('A', substr($hdr, $cfgpos)); $defmode = ($defmode eq 'A') ? 'ANSI' : 'TERADATA'; $attr->{tdat_mode} = $defmode if ($attr->{tdat_mode} eq 'DEFAULT'); return $obj->io_set_error(-1, "Only DBC/SQL sessions allowed in ANSI mode; closing connection.", '08C01') if ($attr->{tdat_mode} eq 'ANSI') && ($attr->{tdat_utility} ne 'DBC/SQL'); $obj->[10] = $attr->{tdat_mode}; ($obj->[7], $obj->[8]) = ($attr->{tdat_mode} eq 'ANSI') ? ('COMMIT WORK', 'ROLLBACK WORK') : ('ET', 'ABORT'); return $dflt_charset; } sub io_connect { my ($obj, $dbsys, $port, $username, $password, $dbname, $attr) = @_; $obj->[18] = -1; $obj->[24] = 'S1000'; $obj->[17] = ''; my $dflt_charset = $obj->io_getconfig($dbsys, $port, $attr) or return undef; $obj->[40] = 0; my $rspmsg; $obj->[19] = 1; $obj->[20] = $attr->{tdat_lsn} || undef; my $lgnsrc = $attr->{tdat_logonsrc}; unless ($lgnsrc) { my $uid = getlogin || getpwuid $< || '????'; $dbsys .= ' ' x (12 - length($dbsys)) if (length($dbsys) < 12); my $app = $0; $app = substr($app, 0, 20) if (length($app) > 20); $app .= ' ' x (4 - length($app)) if (length($app) < 4); $lgnsrc = "$dbsys $$ $uid $app 01 LSS"; } $password = '' unless defined($password); my $charset = $attr->{tdat_charset}; $obj->[9] = (($obj->[9] & 128) ? 128 : 0) | ( (! $charset) ? $dflt_charset : ($charset eq 'UTF8') ? 63 : ($charset eq 'ASCII') ? 127 : 64); $attr->{tdat_charset} = $charset = (($dflt_charset & 127) == 63) ? 'UTF8' : (($dflt_charset & 127) == 127) ? 'ASCII' : 'EBCDIC' unless $charset; $obj->[25] = (($obj->[9] & 127) == 63); $dbsys=~s/COP\d+\s*$//i; my $logonstr = "$dbsys/$username,$password"; my ($hostid, $sessno, $version); ($obj->[15], $obj->[18], $obj->[17], $hostid, $sessno, $version) = DBD::Teradata::Cli->new( $logonstr, $attr->{tdat_mode}, $lgnsrc, $obj->[9], $debug); $obj->[24] = '08C01', return undef if defined($obj->[18]); $obj->[13] = $sessno; $obj->[29] = $hostid & 0x3FF; $obj->[28] = "V2R$version"; $obj->[21] = $1, $obj->[27] = $2, $obj->[36] = $3, $obj->[37] = $4, $obj->[40] = ($1 * 1000000) + ($2 * 10000) + ($3 * 100) + $4 if ($version=~/^(\d+)[A-Za-z]*\.(\d+)\.(\d+)\.(\d+)/); DBI->trace_msg( "Session $$obj[13] connected via CLI for $$obj[28]\n", 1) if $debug; $obj->[2] = 1; $obj->[14] = 0; DBI->trace_msg("Session $$obj[13] connected\n", 1) if $debug; $obj->[38] = (($obj->[40] < 5000000) || ($obj->[19] != 1) || defined($attr->{tdat_lsn})) ? DBD::Teradata::ReqFactory->new() : ($obj->[40] < 6010000) ? DBD::Teradata::APHReqFactory->new() : DBD::Teradata::BigAPHReqFactory->new(); $obj->[18] = 0; $obj->[24] = '00000'; $obj->[11] = 0; $obj->io_tddo("DATABASE $dbname", '') if $dbname; return $obj->[13]; } sub io_disconnect { my ($obj) = @_; unless ($obj->[31]{_logged_off}) { $obj->[15]->cli_disconnect(); $obj->[15] = undef; DBI->trace_msg("Logged off session $obj->[13]\n", 1) if $debug; } $obj->[1] = undef; $obj->[31] = undef; $obj->[18] = undef; $obj->[17] = undef; $obj->[24] = undef; return 1; } sub io_parse_using { my ($req, $typeary, $typelen, $ipackstr, $nameary) = @_; $$ipackstr = ''; my $remnant = ', ' . uc $req; while ($remnant=~/^\s*,\s*(\w+)\s+((DOUBLE\s+PRECISION)|CHARACTER|TIMESTAMP|INTERVAL|VARCHAR|VARBYTE|GRAPHIC|DECIMAL|NUMERIC|SMALLINT|BYTEINT|INTEGER|FLOAT|CHAR|BYTE|REAL|DATE|TIME|INT|DEC)(.*)$/i) { my $name = uc $1; my $vtype = uc $2; $remnant = $4; $vtype = 'FLOAT' if ($vtype=~/^(DOUBLE\s+PRECISION)|REAL$/i); $vtype = 'DEC' if ($vtype=~/^DECIMAL|NUMERIC/i); $vtype = 'CHAR' if ($vtype eq 'CHARACTER'); $vtype = 'INT' if ($vtype eq 'INTEGER'); push @$nameary, $name; my ($prec, $scale); unless ($vtype=~/^INTERVAL|DEC|TIME|TIMESTAMP$/i) { push(@$typeary, $td_type_str2dbi{$vtype}), push(@$typelen, $td_type_str2size{$vtype}), $remnant=~s/^[^,]+(,.*)$/$1/, next unless defined($td_type_str2baseprec{$vtype}); $prec = $td_type_str2baseprec{$vtype}; if ($remnant && ($remnant=~/^\s*\(\s*(\d+)\s*\)(.*)$/)) { $prec = $1; $remnant = $2; } push @$typeary, $td_type_str2dbi{$vtype}; push @$typelen, $prec; $remnant=~s/^[^,]+(,.*)$/$1/; next; } if (($vtype eq 'TIMESTAMP') || ($vtype eq 'TIME')) { $prec = $td_type_str2baseprec{$vtype}; if ($remnant && ($remnant=~/^(\s*\(\s*(\d+)\s*\))?(\s+WITH\s+TIME\s+ZONE)?(.*)$/)) { $prec = $2 if defined($1); $vtype .= ' WITH TIME ZONE' if defined($3); $remnant = $4; } push @$typeary, $td_type_str2dbi{$vtype}; push @$typelen, $td_type_str2size{$vtype} + ($prec ? 1 + $prec : 0); $remnant=~s/^[^,]+(,.*)$/$1/; next; } elsif ($vtype eq 'DEC') { $prec = $td_type_str2baseprec{DEC}; $scale = $td_type_str2basescale{DEC}; if ($remnant && ($remnant=~/^\s*\(\s*(\d+)\s*(,\s*(\d+)\s*)?\)(.*)$/)) { $prec = $1; $scale = $3 if defined($2); $remnant = $4; } push @$typelen, (($prec * 256) + $scale); push @$typeary, $td_type_str2dbi{'DEC'}; $remnant=~s/^[^,]+(,.*)$/$1/; next; } return undef unless $remnant && ($remnant=~/^\s*(YEAR|MONTH|DAY|HOUR|MINUTE|SECOND)(.*)$/); my $intvl = $1; $remnant = $2; $prec = $td_type_str2baseprec{$intvl}; $scale = 0; if ($intvl eq 'SECOND') { if ($remnant && ($remnant=~/^\s*\(\s*(\d+)(\s*,\s*(\d+))?\s*\)(.*)$/)) { $prec = $1; $scale = defined($3) ? $3 : 6; $remnant = $4; } push @$typelen, $td_type_str2size{"INTERVAL SECOND"} + $prec + ($scale ? $scale + 1 : 0); push @$typeary, $td_type_str2dbi{"INTERVAL SECOND"}; $remnant=~s/^[^,]+(,.*)$/$1/; next; } push(@$typelen, $td_type_str2size{"INTERVAL $intvl"} + $prec), push(@$typeary, $td_type_str2dbi{"INTERVAL $intvl"}), $remnant=~s/^[^,]+(,.*)$/$1/, next unless $remnant && ($remnant=~/^(\s*\(\s*(\d+)\s*\))?(\s+TO\s+(MONTH|HOUR|MINUTE|(SECOND(\s*\(\s*(\d+)\s*\))?)))?(.*)$/) && (defined($1) || defined($3)); $vtype = defined($3) ? defined($5) ? "INTERVAL $intvl TO SECOND" : "INTERVAL $intvl TO $4" : "INTERVAL $intvl"; $prec = $2 if defined($1); $scale = defined($5) ? (defined($7) ? $7 : $td_type_str2basescale{SECOND}) : 0; push @$typelen, $td_type_str2size{$vtype} + $prec + ($scale ? 1 + $scale : 0); push @$typeary, $td_type_str2dbi{$vtype}; $remnant=~s/^[^,]+(,.*)$/$1/; } my $prec = 0; my $i = 0; my $pstr; $$ipackstr = ''; while ($i < scalar(@$typeary)) { $prec = ($$typeary[$i] == 3) ? $td_decszs[($$typelen[$i] >> 8) & 31] : $$typelen[$i]; $pstr = $td_type_dbi2pack{$$typeary[$i]}; $$ipackstr .= " $pstr"; $$ipackstr .= $prec if (uc $pstr eq 'A') || ($pstr eq 'U'); $i++; } return scalar @$typeary; } sub io_parse_call { my ($obj, $stmt, $parmdesc) = @_; return undef unless ($stmt=~/^\s*CALL\s+([^\s\(]+)\s*(\(.+\))?\s*;?$/i); my ($spname, $parmList) = (uc $1, $2); $parmList=~s/^\((.+)\)$/$1/; $parmList=~s/^\s+//; $parmList=~s/\s+$//; if ($parmList ne '') { $parmList=~s/DEC(IMAL)?\s*\(\s*(\d+)\s*,\s*(\d+)\s*\)/DEC($2;$3)/ig; my $phCount = ($parmList=~tr/\?//); my @parmAry = split(',', $parmList); for (my $i = 0; $i <= $#parmAry; $i++) { $parmAry[$i]=~s/;/,/g; $parmAry[$i]=~s/^\s+//; $parmAry[$i]=~s/\s+$//; $$parmdesc[$i] = 3, next if ($parmAry[$i]=~/(\?|\:\w+)/); $$parmdesc[$i] = 4, next if (uc $parmAry[$i] ne 'NULL') && ($parmAry[$i]=~/^[_A-Za-z]\w+/); $$parmdesc[$i] = 2; } } 1; } sub io_prepare { my ($obj, $dbh, $make_sth, $dbreq, $rowid, $attribs, $compatible, $passthru) = @_; $compatible = '999.0' unless defined $compatible; my @ptypes = (); my @plens = (); my $usephs = 0; my @usenames = (); my @stmtinfo = (undef); my $ipackstr = ''; $obj->[18] = 0; $obj->[24] = '00000'; $obj->[17] = ''; my $tmpreq = $dbreq; $tmpreq=~s/\s+WHERE\s+CURRENT\s+OF\s+[^\s;]+(\s*;)?\s*$/ WHERE CURRENT/ig; $tmpreq =~s/'[^']+'/''/g; $tmpreq=~s/\-\-.*\r/ /g; $tmpreq=~s/\/\*.*?\\*\// /g; my $datainfo = ''; $ipackstr = ''; $usephs = ($tmpreq =~ tr/\?//); return $obj->io_set_error('Placeholders not supported for utility applications.') if $usephs && (($obj->[19] != 1) || $obj->[20]); my $usingvars = 0; $tmpreq = uc $2, $usingvars = io_parse_using($1, \@ptypes, \@plens, \$ipackstr, \@usenames) if ($tmpreq=~/^USING\s*\((.+)\)\s*((SELECT|EXECUTE|LOCKING|IGNORE|INSERT|UPDATE|DELETE|MERGE|ABORT|EXEC|LOCK|MARK|CALL|INS|UPD|SEL|DEL|DO)\s+(.+))$/i); return $obj->io_set_error('Invalid USING clause.') if ($usingvars == -1); return $obj->io_set_error('Can\'t mix USING clause and placeholders in same statement.') if ($usephs > 0) && ($usingvars > 0); if ($usephs) { @ptypes = ((12) x $usephs); @plens = (($phdfltsz) x $usephs); $ipackstr = 'S/a* ' x $usephs; } unless ($compatible lt '2.1') { $tmpreq = $9 while ($tmpreq=~/^LOCK(ING)?(((\s+TABLE|DATABASE|VIEW)?\s+\S+)|ROW|)(\s+(FOR|IN))?\s+\S+(\s+MODE)?(\s+NOWAIT)?\s+(.+)$/i); my @s = split(';', $tmpreq); my $i = 1; my $t; foreach $t (@s) { last unless ($t=~/^\s*(DATABASE|COLLECT|REPLACE|MODIFY|REVOKE|UPDATE|INSERT|DELETE|CREATE|MERGE|ALTER|GRANT|DROP|GIVE|UPD|INS|DEL|[CRD][TVMP]|SET)\s+(VOLATILE\s+|GLOBAL\s+TEMPORARY\s+)?(MULTISET\s+|SET\s+)?(\S+)(\s+(\S+))?/i); my ($keywd, $keytyp, $keyqual) = (uc $1, uc $4, uc $6); last if (($keywd eq 'REPLACE') || ($keywd eq 'CREATE')) && (($keytyp eq 'MACRO') || ($keytyp eq 'PROCEDURE')); $stmtinfo[$i]->{ActivityType} = (($keywd eq 'SET') || ($keytyp eq 'JOIN') || ($keytyp eq 'HASH')) ? join(' ', ucfirst (lc $keywd), ucfirst(lc $keytyp), ucfirst(lc $keyqual)) : (($keywd=~/^CREATE|DROP|RENAME|REPLACE|ALTER|COLLECT|MODIFY$/) || (($keywd eq 'DELETE') && (($keytyp eq 'DATABASE') || ($keytyp eq 'JOURNAL')))) ? ucfirst (lc $keywd) . ' ' . ucfirst(lc $keytyp) : exists $stmt_abbrv{$keywd} ? $stmt_abbrv{$keywd} : ucfirst(lc $keywd); $stmtinfo[$i]->{ActivityCount} = 0; $i++; } return &$make_sth( $dbh, { %$attribs, Statement => $dbreq, tdat_stmt_info => \@stmtinfo, NUM_OF_FIELDS => 0, NUM_OF_PARAMS => (($usingvars > 0) ? $usingvars : $usephs), _ptypes => \@ptypes, _plens => \@plens, _packstr => $ipackstr, _usenames => \@usenames, _usephs => $usephs } ) if ($i > $#s+1); } @stmtinfo = (undef); my @parmdesc = (); my ($parmnum, $phnum) = (0,0); my $is_a_call = undef; if ($tmpreq=~/^\s*CALL\s+/i) { return undef unless $obj->io_parse_call($tmpreq, \@parmdesc); $is_a_call = 1; } my $reqmsg = $obj->[38]->prepareRequest($obj, $rowid, $usingvars, $obj->[3], $dbreq); return $obj->io_set_error('System error: can\'t send() PREPARE request.') unless $obj->io_quicksend(length($reqmsg), undef, $reqmsg); my $rspmsg = $obj->io_getcliresp; return undef unless $rspmsg ; my $rsplen = length($$rspmsg); $$passthru = $$rspmsg if defined($passthru); my ($f, $l, $tderr, $tdelen); my ($stmtno, $rowcnt, $warncode, $fldcount, $activity, $warnlen, $pcl); my $nextcol = 0; my $curpos = 52; my $pclhdrsz = 4; my %sthargs = ( %$attribs, Statement => $dbreq, tdat_stmt_info => [ undef ], NAME => [], TYPE => [], PRECISION => [], SCALE => [], NULLABLE => [], tdat_TYPESTR => [], tdat_TITLE => [], tdat_FORMAT => [], _unpackstr => [], _ptypes => \@ptypes, _plens => \@plens, _packstr => $ipackstr, _usenames => \@usenames, _usephs => $usephs, _parmdesc => \@parmdesc, _parmmap => {}, _parmnum => \$parmnum, _phnum => \$phnum, ); my $stmtinfo = $sthargs{tdat_stmt_info}; while ($curpos < $rsplen) { ($f, $l, $pclhdrsz) = _getPclHeader($$rspmsg, $curpos); $curpos += $l , next if (($f == 11) || ($f == 12)); if ($f == 8) { ($stmtno, $rowcnt, $warncode, $fldcount, $activity, $warnlen) = unpack('SLSSSS', substr($$rspmsg, $curpos+$pclhdrsz, 14)); $stmtinfo->[$stmtno]{ActivityType} = ($td_activity_types{$activity}) ? $td_activity_types{$activity} : 'Unknown'; $stmtinfo->[$stmtno]{ActivityCount} = $rowcnt; $sthargs{tdat_unpackstr}[$nextcol] = ''; $stmtinfo->[$stmtno]{Warning} = "Warning $warncode: " . substr($rspmsg, 18, $warnlen) if $warnlen; $curpos += $l; next; } if (($f == 9) || ($f == 49)) { ($stmtno, $rowcnt, $tderr, $tdelen) = unpack('SSSS', substr($$rspmsg, $curpos+$pclhdrsz, 8)); my $tdemsg = substr($$rspmsg, $curpos+$pclhdrsz+8, $tdelen); DBI->trace_msg("ERROR $tderr\: $tdemsg\n", 2); $obj->io_set_error($tderr, (($f == 9) ? 'Failure' : 'Error') . " $tderr\: $tdemsg on Statement $stmtno."); $stmtinfo->[$stmtno]{SummaryStarts} = $stmtinfo->[$stmtno]{SummaryEnds} = $stmtinfo->[$stmtno]{StartAt} = $stmtinfo->[$stmtno]{EndsAt} = undef; return undef; } return $obj->io_set_error("Invalid parcel stream: got $f when PREPINFO expected.") if ($f != 86); $nextcol = $obj->io_proc_prepinfo( substr($$rspmsg, $curpos+$pclhdrsz, $l - $pclhdrsz), $stmtno, \%sthargs, $activity, $is_a_call, $nextcol); $curpos += $l; } DBI->trace_msg("Session $obj->[13] PREPAREd $dbreq\n", 1) if $debug; $$passthru = undef if defined($passthru); $sthargs{NUM_OF_FIELDS} = scalar @{$sthargs{NAME}}; $sthargs{NUM_OF_PARAMS} = $usingvars || $usephs; return &$make_sth($dbh, \%sthargs); } sub io_proc_prepinfo { my ($obj, $pcl, $stmtno, $sthargs, $activity, $is_a_call, $nextcol) = @_; my $curpos = 0; my ($sumcnt, $colcnt) = unpack('SS', substr($pcl, 8, 4)); my $packstr = ''; my $stmtinfo = $sthargs->{tdat_stmt_info}[$stmtno]; $stmtinfo->{StartsAt} = $stmtinfo->{StartsAt} = undef, return $nextcol unless $colcnt || $sumcnt; my ($phnum, $parmnum, $parmdesc, $parmmap) = ($sthargs->{_phnum}, $sthargs->{_parmnum}, $sthargs->{_parmdesc}, $sthargs->{_parmmap}); my ($datatype, $datalen, $cname, $cfmt, $ctitle); $curpos += 12; $stmtinfo->{StartsAt} = $nextcol; $stmtinfo->{EndsAt} = $nextcol + $colcnt - 1; my $nextsum = 0; $stmtinfo->{SummaryStarts} = [ 0 ], $stmtinfo->{SummaryEnds} = [ 0 ] if $sumcnt; while (1) { for (my $i = 0; $i < $colcnt; $i++, $nextcol++) { ($datatype, $datalen, $cname, $cfmt, $ctitle) = unpack('SS S/a S/a S/a', substr($pcl, $curpos)); $curpos += (4 + 2 + length($cname) + 2 + length($cfmt) + 2 + length($ctitle)); if ($activity == 105) { $datatype -= 500; if ($is_a_call) { $$phnum++ if ($$parmdesc[$$parmnum] & 1); $$parmnum++, $nextcol--, next unless ($datatype & 3); $$parmdesc[$$parmnum] |= 4; $$parmmap{$$phnum} = $nextcol if ($$parmdesc[$$parmnum] & 1); $$parmnum++; $stmtinfo->{EndsAt} = $nextcol; } $datatype &= 0xfffc; } $sthargs->{NAME}[$nextcol] = ($cname eq '') ? (($ctitle eq '') ? "COLUMN$nextcol" : $ctitle) : $cname; my $ttype = $sthargs->{TYPE}[$nextcol] = $td_type_code2dbi{$datatype & 0xfffe}; $sthargs->{NULLABLE}[$nextcol] = ($activity == 105) ? 1 : $datatype & 1; $sthargs->{tdat_TITLE}[$nextcol] = $ctitle; $cfmt = uc $cfmt; $cfmt = '-(' . (length($1) + 1) . ")$2" if ($cfmt=~/^(-+)(.*)/); $sthargs->{tdat_FORMAT}[$nextcol] = $cfmt; my $prec = $sthargs->{PRECISION}[$nextcol] = ($ttype == 3) ? (($datalen >> 8) & 31) : $datalen; my $scale = $sthargs->{SCALE}[$nextcol] = ($ttype == 3) ? ($datalen & 255) : 0; my $len = ($ttype == 3) ? $td_decszs[$prec] : $datalen; $packstr .= (($ttype == -2) || ($ttype == 3)) ? "a$len " : (($ttype == 1) ? "A$len " : ($td_type_dbi2pack{$ttype}) . ' '); $sthargs->{tdat_FORMAT}[$nextcol] = "6($prec)" if ($ttype == -2) || ($ttype == -3); my $typestr = $td_type_dbi2str{$ttype}; $typestr .= '(' . $prec . (($ttype == 3) ? ", $scale)" : ')') if $td_type_str2baseprec{$typestr}; $sthargs->{tdat_TYPESTR}[$nextcol] = $typestr; DBI->trace_msg( ($ttype != 3) ? "$sthargs->{NAME}[$nextcol]\: $ttype LENGTH $prec\n" : "$sthargs->{NAME}[$nextcol]\: DECIMAL($prec, $scale) LENGTH $td_decszs[$len]\n", 1) if $debug; } my $packidx = $nextsum ? $stmtinfo->{SummaryStarts}[$nextsum - 1] : $stmtinfo->{StartsAt}; $packstr=~s/\*//g; $sthargs->{_unpackstr}[$packidx] = $packstr; $packstr = ''; last unless $sumcnt; $colcnt = unpack('S', substr($pcl, $curpos)); $stmtinfo->{SummaryStarts}[$nextsum] = $nextcol; $stmtinfo->{SummaryEnds}[$nextsum] = $nextcol + $colcnt - 1; $nextsum++; $curpos += 2; $sumcnt--; } return $nextcol; } sub io_execute { my ($obj, $sth, $datainfo, $indicdata, $rowid) = @_; $obj->[18] = 0; $obj->[24] = '00000'; $obj->[17] = ''; my $stmtinfo = $sth->{tdat_stmt_info}; my $stmtno = $sth->{tdat_stmtno}; my $nowait = $sth->{tdat_nowait}; my $stmt = $sth->{Statement} || ''; my $keepresp = ($sth->{tdat_keepresp} || ($stmt=~/\s+FOR\s+CURSOR\s*$/i)); my $rawmode = $sth->{tdat_raw_in}; my $reqmsg = ''; my $reqlen = 0; my $modepcl = ($rawmode && defined($rawmodes{$rawmode})) ? $rawmodes{$rawmode} : 68; my $partition = $obj->[19]; my $reqfac = $obj->[38]; $stmt=~s/\s+WHERE\s+CURRENT\s+OF\s+([^\s;]+)\s*;?\s*$/ WHERE CURRENT/i; my $forCursor = ($stmt=~/\s+WHERE\s+CURRENT$/i) && $rowid; if (($partition == 1) || (($partition == 6) && ($stmt ne ';'))) { $reqlen = 4 + length($stmt) + 6 + ((defined($datainfo) && length($datainfo)) ? 4 + length($datainfo) : 0) + ((defined($indicdata) && length($indicdata)) ? 4 + length($indicdata) : 0) + ($forCursor ? 4 + length($rowid) : 0) + ($sth->{tdat_mload} ? 14 : 0); if ($reqlen > 65535) { $reqlen += 4 + 4 + (length($datainfo) ? 4 : 0) + (length($indicdata) ? 4 : 0) + (($forCursor && $rowid) ? 4 : 0); $obj->[26] = 1; } else { $obj->[26] = undef; } } if ($sth->{Statement}=~/^\s*(CREATE|REPLACE)\s+PROCEDURE\s+/i) { my $pos = 0; my $segment = 1; my $len = length($sth->{Statement}); my $sz = 0; while ($len) { $sz = ($len > 64000) ? 64000 : $len; $len -= $sz; ($reqmsg, $pos) = $reqfac->spRequest($obj, $sz, $pos, $segment, $sth, $obj->[3]); $segment++; my $treqno = $obj->[2]; $obj->io_quicksend(length($reqmsg), undef, $reqmsg) or return undef; $obj->[1]{$treqno} = $sth; $sth->{_p}[12] = $treqno; last unless $len; return undef unless defined($obj->io_Realize($sth)); } return ($nowait ? -1 : $obj->io_Realize($sth)); } return $obj->io_set_error('Maximum request size exceeded.') if ($obj->[40] < 5000000) && ($reqlen > 65535); if ($partition == 1) { $reqmsg = $reqfac->sqlRequest($obj, $sth, $forCursor, $rowid, $modepcl, $keepresp, $obj->[3], $stmt, $datainfo, $indicdata); } delete $obj->[1]{$_} foreach (keys %{$obj->[1]}); my $treqno = $obj->[2]; if (($partition == 5) || ($partition == 4)) { $obj->io_quicksend($obj->[32], undef, $obj->[16]) or return undef; } else { $obj->io_tdsend($reqmsg) or return undef; } $obj->[1]{$treqno} = $sth; $sth->{_p}[12] = $treqno; return ($nowait) ? -1 : $obj->io_Realize($sth); } sub io_fetch { my ($obj, $sth, $ary, $retstr) = @_; $obj->[18] = 0; $obj->[24] = '00000'; $obj->[17] = ''; my $sthp = $sth->{_p}; return 0 unless $sthp->[17]; my $maxlen = ($ary) ? $sthp->[14] : 1; my $stmtno = $sth->{tdat_stmt_num}; my ($f, $l, $failed) = (0,0,0,0); my $rspmsg = $sthp->[17]; my $pos = $sthp->[19]; my $rsplen = ($$rspmsg) ? length($$rspmsg) : 0; my $partition = $obj->[19]; my $stmtinfo = $sth->{tdat_stmt_info}; my $stmthash = ($stmtno) ? $$stmtinfo[$stmtno] : undef; my $endstmt = 0; my $total_activity = 0; my $arycnt = 0; if ($pos >= $rsplen) { $rspmsg = $obj->io_tdcontinue($sth, 0); return 0 unless $$rspmsg; $sthp->[17] = $rspmsg; $rsplen = length($$rspmsg); $obj->io_tdcontinue($sth, 1) if (! $sthp->[22]) && $obj->[14]; $pos = 52; } my ($pclhdrsz, $rowcnt, $tderr, $fldcount, $activity, $tdelen, $tdemsg); ($f, $l, $pclhdrsz) = _getPclHeader($$rspmsg, $pos); $sth->{tdat_more_results} = 1; while (($f != 10) && ($f != 105)) { $sthp->[19] = $pos + $l; if ($f == 12) { $sthp->[17] = undef; $sthp->[19] = 0; $sth->{tdat_more_results} = 0; $obj->io_tddo('COMMIT WORK'), $obj->[11] = 0 if ($obj->[10] eq 'ANSI') && $obj->[11] && $obj->[31]{AutoCommit}; $sth->{tdat_more_results} = 0, delete $obj->[1]{$sthp->[12]}, $sthp->[12] = 0, unless ($obj->[19] == 3) || $sth->{tdat_keepresp}; return $total_activity; } elsif (($f == 9) || ($f == 49)) { ($stmtno, $rowcnt, $tderr, $tdelen) = unpack('SSSS', substr($$rspmsg, $pos+$pclhdrsz, 8)); $tdemsg = substr($$rspmsg, $pos+$pclhdrsz+8, $tdelen); DBI->trace_msg("ERROR $tderr\: $tdemsg\n", 2); $obj->io_set_error($tderr, (($f == 9) ? 'Failure' : 'Error') . " $tderr\: $tdemsg on Statement $stmtno."); $sth->{tdat_stmt_num} = $stmtno; $stmthash = $$stmtinfo[$stmtno]; $stmthash->{ErrorCode} = $tderr; $stmthash->{ErrorMessage} = $tdemsg; $obj->[11] = 0 if ($obj->[10] ne 'ANSI'); delete $obj->[1]{$sthp->[12]}, $sthp->[12] = 0, $sthp->[17] = undef, $sthp->[19] = 0, $sth->{tdat_more_results} = 0, $sthp->[22] = 1, return undef if ($obj->[10] ne 'ANSI') || ($stmtno == $#{$sth->{tdat_stmt_info}}); } elsif ($f == 8) { ($stmtno, $rowcnt, $tderr, $fldcount, $activity, $tdelen) = unpack('SLSSSS', substr($$rspmsg, $pos+$pclhdrsz, 14)); $stmtno++ unless $stmtno; $stmthash = $$stmtinfo[$stmtno]; $stmthash->{ActivityType} = ($td_activity_types{$activity}) ? $td_activity_types{$activity} : 'Unknown'; $stmthash->{ActivityCount} = $rowcnt; $total_activity += $rowcnt; delete $stmthash->{Warning}; $stmthash->{Warning} = "Warning $tderr\: " . substr($$rspmsg, $pos+$pclhdrsz+14, $tdelen) if $tdelen; $sth->{tdat_stmt_num} = $stmtno; } elsif ($f == 17) { ($stmtno, $fldcount, $rowcnt, $activity, $tderr, $tdelen) = unpack('SSLSSS', substr($$rspmsg, $pos+$pclhdrsz, 14)); $stmtno++ unless $stmtno; $stmthash = $$stmtinfo[$stmtno]; $stmthash->{ActivityType} = ($td_activity_types{$activity}) ? $td_activity_types{$activity} : 'Unknown'; $stmthash->{ActivityCount} = $rowcnt; $total_activity += $rowcnt; delete $stmthash->{Warning}; $stmthash->{Warning} = "Warning $tderr\: " . substr($$rspmsg, $pos+$pclhdrsz+14, $tdelen) if $tdelen; $sth->{tdat_stmt_num} = $stmtno; } elsif ($f == 33) { $stmthash->{IsSummary} = (unpack('S', substr($$rspmsg, $pos+$pclhdrsz)) - 1); $stmthash->{SummaryPosition} = [ ], $stmthash->{SummaryPosStart} = [ ] unless defined($stmthash->{SummaryPosition}); } elsif ($f == 35) { delete $stmthash->{IsSummary}; } elsif ($f == 46) { my $sumpos = $stmthash->{SummaryPosition}; my $sumstart = $stmthash->{SummaryPosStart}; push(@$sumstart, scalar(@$sumpos)); } elsif ($f == 34) { my $sumpos = $stmthash->{SummaryPosition}; push(@$sumpos, (unpack('S', substr($$rspmsg, $pos+$pclhdrsz)))); } elsif ($f == 29) { $stmthash->{Prompt} = 1; $obj->[6] = 1; } elsif ($f == 11) { delete $stmthash->{SummaryPosStart}; delete $stmthash->{SummaryPosition}; $endstmt = 1; } elsif (($f == 71) && (exists $stmthash->{ActivityType}) && (($stmthash->{ActivityType} eq 'Help') || ($stmthash->{ActivityType} eq 'Call') || ($stmthash->{ActivityType} eq 'Monitor SQL') || (($stmthash->{ActivityType} eq 'Monitor Session') && ($stmtno > 1)))) { my $rc = $obj->io_proc_datainfo($sth, substr($$rspmsg, $pos+$pclhdrsz, $l - $pclhdrsz), $stmtno); DBI->trace_msg("ERROR -1: DATAINFO for unexpected statement\n", 2), return $obj->io_set_error("Failure -1: DATAINFO for unexpected Statement $stmtno.") if ($rc == -1); DBI->trace_msg("ERROR -2: DATAINFO does not match defined fields.\n", 2), return $obj->io_set_error(-2, "Failure -2: DATAINFO does not match defined fields for Statement $stmtno.") if ($rc == -2); } elsif ($f == 121) { $sthp->[6] = substr($$rspmsg, $pos+$pclhdrsz, $l - $pclhdrsz) . pack('L', $sthp->[12]); } elsif (($f == 20) || ($f == 22) || ($f == 24)) { $sthp->[25] = 1; } elsif (($f == 21) || ($f == 23) || ($f == 25)) { $sthp->[25] = undef; } elsif ($f == 18) { push @{$sthp->[7]}, substr($$rspmsg, $pos+$pclhdrsz, $l - $pclhdrsz) unless $sthp->[25]; } elsif ($f == 19) { push @{$sthp->[7]}, undef unless $sthp->[25]; } elsif ($f == 27) { last unless $retstr; $sthp->[7] = [ ]; $arycnt++ if defined($ary); } elsif ($f == 28) { last if $endstmt; $$retstr = $sthp->[7], $sthp->[19] = $pos + $l, $sthp->[7] = undef, return 1 unless defined($ary); push (@$ary, $sthp->[7]); $f = 32; $sthp->[7] = undef; $sthp->[19] = $pos + $l, $#$ary = $maxlen - 1, return $maxlen if ($arycnt == $maxlen); } elsif (($f != 71) && ($f != 47) && ($f != 26)) { $obj->io_set_error("Received bad parcel $f."); delete $obj->[1]{$sthp->[12]}; $sthp->[12] = 0; $sthp->[17] = undef; $sthp->[19] = 0; $sth->{tdat_more_results} = 0; return undef; } $pos += $l; if (($pos >= $rsplen) && ( ! $sthp->[22])) { $rspmsg = $obj->io_tdcontinue($sth, 0); return 0 unless $rspmsg; $sthp->[17] = $rspmsg; $rsplen = length($$rspmsg); $pos = 52; $obj->io_tdcontinue($sth, 1) if (! $sthp->[22]) && $obj->[14]; $pos = 52; } ($f, $l, $pclhdrsz) = _getPclHeader($$rspmsg, $pos); } $sthp->[19] = $pos, return $total_activity unless $retstr; if ($endstmt) { $sthp->[19] = $pos; return 0 unless defined($ary) && $arycnt; push (@$ary, $sthp->[7]); $sthp->[7] = undef; $sthp->[19] = $pos + $l; $#$ary = $arycnt - 1; return $arycnt; } if (defined($ary)) { $#$ary = $arycnt - 2, return $arycnt if $sthp->[7]; my $i = 0; while (($i < $maxlen) && ($pos < $rsplen) && ($f == 10)) { $$ary[$i] = pack('Sa*c', $l-$pclhdrsz, substr($$rspmsg, $pos+$pclhdrsz, $l - $pclhdrsz), 10), $pos += $l; ($f, $l, $pclhdrsz) = _getPclHeader($$rspmsg, $pos) unless ($pos >= $rsplen); $i++; } $sthp->[19] = $pos; $#$ary = $i-1; return $i; } $sthp->[19] = $pos + $l, return 0 if $sthp->[7]; $$retstr = substr($$rspmsg, $pos+$pclhdrsz, $l - $pclhdrsz); $sthp->[19] = $pos + $l; return 1; } sub io_commit { while ($_[0]->[11]) { return undef unless defined($_[0]->io_tddo($_[0]->[7])); $_[0]->[11] = 0; } return 1; } sub io_rollback { return $_[0]->io_tddo($_[0]->[8]); } sub io_err { return $_[0]->[18]; } sub io_errstr { return $_[0]->[17]; } sub io_state { return $_[0]->[24]; } sub io_finish { my ($obj, $sth) = @_; my $reqno = $sth->{_p}[12]; my $running = (($reqno) && ($obj->[23] == $reqno)); return 1 if (! $running) && $sth->{_p}[22] && (! $sth->{tdat_keepresp}); if ($obj->[15]) { $obj->[15]->cli_end_request($reqno); } delete $obj->[1]{$reqno}; return 1; } sub io_cancel { my ($obj, $sth) = @_; my $reqno = $sth->{_p}[12]; my $running = ($reqno && ($obj->[23] == $reqno)); return 1 if (! $running) && $sth->{_p}[22] && (! $sth->{tdat_keepresp}); ($running) ? $obj->[15]->cli_abort_request($reqno) : $obj->[15]->cli_end_request($reqno); $obj->io_getcliresp, delete $obj->[1]{$reqno} unless $sth->{tdat_nowait}; return 1; } sub io_FirstAvailList { my ($sesslist, $timeout) = @_; my $i = 0; my $rmask = ''; my $wmask = ''; my $emask = ''; my ($rout, $wout, $eout); my %fdhash = (); my @avails = (); my @clilist = (); my %seshash = (); foreach my $obj (@$sesslist) { $i++, next unless defined($obj); $fdhash{$obj} = $i++, vec($rmask, $obj, 1) = 1, next unless (ref $obj); push(@avails, $i++), next unless $obj->[23]; push (@clilist, $i++); } return ($#avails < 0) ? undef : @avails if ($rmask eq '') && ($#clilist < 0); my $started = time(); $timeout = undef if defined($timeout) && ($timeout < 0); my $lcltimeout = ($#clilist >= 0) ? 0 : $timeout; if ($rmask ne '') { $wmask = 0; $emask = $rmask; my $n = select($rout=$rmask, undef, $eout=$emask, $lcltimeout); return ($#avails < 0) ? undef : @avails if ($n <= 0) && ($#clilist < 0); foreach (keys(%fdhash)) { push(@avails, $fdhash{$_}) if vec($rout, $_, 1) || vec($eout, $_, 1); } } return (($#avails >= 0) ? @avails : undef) unless ($#clilist >= 0); my @sesobjs = (); my ($obj, $reqid, $keepresp); $obj = $sesslist->[$_], $reqid = $obj->[23], $keepresp = ($obj->[1] && (exists $obj->[1]{$reqid})) ? $obj->[1]{$reqid}{tdat_keepresp} : undef, push(@sesobjs, $_, $obj->[15], $reqid, $keepresp) foreach (@clilist); my @list = DBD::Teradata::Cli::cli_wait_for_response($timeout, @sesobjs); push @avails, @list; return ($#avails >= 0) ? @avails : undef; } sub io_Realize { my ($obj, $sth) = @_; my $rspmsg = $obj->io_getcliresp($sth); return undef unless $rspmsg; $obj->io_tdcontinue($sth, 1) if (! $sth->{_p}[22]) && $obj->[14]; my $rc = $obj->io_fetch($sth, undef, undef); $sth->{Active} = undef, return undef unless defined($rc); return $rc; } sub io_proc_datainfo { my ($obj, $sth, $pcl, $stmtno) = @_; my $flds = 2 * unpack('S', $pcl); my $descr = "S$flds"; $flds /= 2; my @diflds = unpack($descr, substr($pcl,2)); my @ftype = (); my @ftypestr = (); my @fprec = (); my @fscale = (); my @fnullable = (); my @packstrs = (); my $prec = 0; my $stmtinfo = $sth->{tdat_stmt_info}; my $names = $sth->{NAME}; my $stmthash = $$stmtinfo[$stmtno]; return -1 unless $stmthash; my ($i, $j, $t); my $starts = $stmthash->{StartsAt}; for ($i = $starts, $j = 0; $i < ($starts + $flds); $i++, $j += 2) { $t = $diflds[$j], $diflds[$j] = (($t & 0xFF)<<8) + ($t>>8), $t = $diflds[$j + 1], $diflds[$j + 1] = (($t & 0xFF)<<8) + ($t>>8) if ($diflds[$j] > 1300); $diflds[$j] -= 500 if ($diflds[$j] > 800); $diflds[$j] &= 0xfffd; last unless defined($td_type_code2str{($diflds[$j] & 0xfffe)}); if ($i > $stmthash->{EndsAt}) { print "Got $flds valid fields, but expected only ", ($stmthash->{EndsAt} - $starts + 1), " expected.\n"; return -2; } $ftype[$i] = $td_type_code2dbi{($diflds[$j] & 0xfffe)}; $ftypestr[$i] = $td_type_code2str{($diflds[$j] & 0xfffe)}; $fnullable[$i] = ($diflds[$j] & 1); my $len = $diflds[$j+1]; $fprec[$i] = ($ftype[$i] == 3) ? (($len >> 8) & 0xFF) : $len; $fscale[$i] = ($ftype[$i] == 3) ? ($len & 0xFF) : 0; $prec = ($ftype[$i] == 3) ? $td_decszs[(($len >> 8) & 31)] : $len; $packstrs[$starts] .= (($ftype[$i] == -2) || ($ftype[$i] == 3)) ? "a$prec " : ($ftype[$i] == 1) ? "A$prec " : $td_type_dbi2pack{$ftype[$i]} . ' '; $ftypestr[$i] .= '(' . $fprec[$i] . (($ftype[$i] == 3) ? "$fscale[$i])" : ')') if defined($td_type_str2baseprec{$ftypestr[$i]}); } $sth->{TYPE} = \@ftype; $sth->{PRECISION} = \@fprec; $sth->{SCALE} = \@fscale; $sth->{NULLABLE} = \@fnullable; $sth->{tdat_TYPESTR} = \@ftypestr; $sth->{_p}[10] = \@packstrs; return $flds; } sub io_rewind { my ($obj, $sth) = @_; return undef unless ($obj->[19] == 1) && $sth->{_p}[26] && $sth->{tdat_keepresp}; my $reqno = $sth->{_p}[12]; $obj->[14] = 0; return undef if $obj->[23] && (! $obj->io_getcliresp); $sth->{_p}[17] = undef; $sth->{_p}[19] = undef; my $reqmsg = $obj->[38]->rewindRequest($obj, $reqno, $obj->[3]) or return undef; $obj->io_tdsend($reqmsg) or return undef; return $sth->{tdat_nowait} ? -1 : $obj->io_Realize($sth); } sub io_clone { $inited = 0; return 1; } 1; =pod =head1 NAME DBD::Teradata - DBI driver for Teradata =head1 SYNOPSIS use DBI; $dbh = DBI->connect('dbi:Teradata:hostname', 'user', 'password'); See L for more information. =head1 DESCRIPTION Refer to the included doc/index.html, or L for detailed information. B: This version has been deprecated in favor of the more complete and maintained GPL version available at L. =head2 PREREQUISITES Install Perl (minimum version 5.8). Build, test and install the DBI module (minimum version 1.36). Remember to *read* the DBI README, this README, and the included doc/index.html CAREFULLY! I had a lot of info to distill, and POD, though quaint and convenient for READMEs like this, just isn't as expressive as HTML...hence doc/index.html. Please refer to doc/index.html for detailed usage information. =head2 *** BUILDING: =head3 NOTE The provided test suite is not suitable for normal Perl "make test", as it requires a Teradata database and a username and password for an account with various privileges (e.g., CREATE PROCEDURE). After installing, you can verify the install by running perl t/test.pl where is the name of your Teradata server. NOTE that CLI does NOT support numeric IP addresses, nor addresses with the COPn suffix already applied, i.e., perl t/test.pl 129.123.345.78 dbc dbc # WRONG perl t/test.pl DBCCOP1 dbc dbc # WRONG perl t/test.pl DBC dbc dbc # RIGHT! =head3 Building For Microsoft Windows You'll need the nmake utility, available with the various Visual Studio tools. You'll also need to make sure your command prompt is configured to find nmake; see the Visual Studio documents for how to do that. To build: perl Makefile.pl # use a perl that's in your PATH nmake nmake install =head3 Building For UNIX/Linux perl Makefile.pl # use a perl that's in your PATH make make install =head2 IF YOU HAVE PROBLEMS Please read the doc/index.html file which includes important information, including tips and workarounds for various platform-specific problems. =head2 SUPPORT INFORMATION For the latest DBD::Teradata information, please see L. Bug reports/Comments/suggestions/enhancement requests may be sent to L. B This free version of DBD::Teradata is a minimal implementation of the commercially supported version. Refer to L for details on the differences. =head3 MAILING LISTS As a user or maintainer of a local copy of DBD::Teradata, you need to be aware of the following addresses: The DBI mailing lists located at dbi-announce@perl.org for announcements dbi-dev@perl.org for developer/maintainer discussions dbi-users@perl.org for end user level discussion and help Refer to L for details on subscribing to these lists. =head2 COPYRIGHT, AUTHOR, and LICENSE Copyright(C) 2001-2007, Presicient Corporation, USA. All rights reserved. Permission is granted to use this software according to the terms of the L, as specified in the Perl README file, B that commercial redistribution, either electronic or via physical media, as either a standalone package, or incorporated into a third party product, requires prior written approval of the copyright holder. This software 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. Presicient Corp. reserves the right to provide support for this software to individual sites under a separate (possibly fee-based) agreement. Teradata(R) is a registed trademark of NCR Corporation. =cut package DBD::Teradata::Diagnostic; use Time::HiRes qw(time); use Exporter; our @ISA = qw(Exporter); use strict; use warnings; our @EXPORT = qw( io_hexdump io_hdrdump io_pcldump); our @EXPORT_OK = qw( @td_pclstrings %td_msgkind_map); our @td_pclstrings = qw( Unknown PclREQUEST PclRSUP PclDATA PclRESP PclKEEPRESP PclABORT PclCANCEL PclSUCCESS PclFAILURE PclRECORD PclENDSTATEMENT PclENDREQUEST PclFMREQ PclFMRSUP PclVALUE PclNULLVALUE PclOK PclFIELD PclNULLFIELD PclTITLESTART PclTITLEEND PclFORMATSTART PclFORMATEND PclSIZESTART PclSIZEEND PclSIZE PclRECSTART PclRECEND PclPROMPT PclENDPROMPT PclREWIND PclNOP PclWITH PclPOSITION PclENDWITH PclLOGON PclLOGOFF PclRUN PclRUNRESP PclUCABORT PclHOSTSTART PclCONFIG PclCONFIGRESP PclSTATUS PclIFPSWITCH PclPOSSTART PclPOSEND PclBULKRESP PclERROR PclDATE PclROW PclHUTCREDBS PclHUTDBLK PclHUTDELTBL PclHUTINSROW PclHUTRBLK PclHUTSNDBLK PclENDACCLOG PclHUTRELDBCLK PclHUTNOP PclHUTBLD PclHUTBLDRSP PclHUTGETDDT PclHUTGETDDTRSP PclHUTIDX PclHUTIDXRSP PclFIELDSTATUS PclINDICDATA PclINDICREQ Unknown PclDATAINFO PclIVRSUP Unknown Unknown Unknown Unknown Unknown Unknown Unknown Unknown Unknown Unknown Unknown Unknown PclOPTIONS PclPREPINFO Unknown PclCONNECT PclLSN PclCOMMIT Unknown Unknown Unknown Unknown Unknown Unknown Unknown Unknown Unknown PclASSIGN PclASSIGNRSP PclMLOADCTRL Unknown PclMLOAD PclERRORCNT PclSESSINFO PclSESSINFORESP Unknown Unknown Unknown Unknown Unknown Unknown PclSESSOPT PclVOTEREQUEST PclVOTETERM PclCMMT2PC PclABRT2PC PclFORGET PclCURSORHOST PclCURSORDBC PclFLAGGER PclXINDICREQ PclPREPINFOX Unknown Unknown Unknown PclMULTITSR PclSPL PclSSOAUTHREQ PclSSOAUTHRESP PclSSOREQ PclSSODOMAIN PclSSORESP PclSSOAUTHINFO PclUSERNAMEREQ PclUSERNAMERESP Unknown Unknown PclMULTIPARTDATA PclENDMULTIPARTDATA PclMULTIPARTINDICDATA PclENDMULTIPARTINDICDATA PclMULTIPARTREC PclENDMULTIPARTREC PclDATAINFOX PclMULTIPARTRSUP PclMULTIPARTREQ PclELICITDATAMAILBOX PclELICITDATA PclELICITFILE PclELICITDATARECVD PclBIGRESP PclBIGKEEPRESP Unknown Unknown PclSETPOSITION PclROWPOSITION PclOFFSETPOSITION Unknown Unknown Unknown PclRESULTSUMMARY PclERRORINFO PclGTWCONFIG PclCLIENTCONFIG PclAUTHMECH ); our %td_msgkind_map = qw( 1 COPKINDASSIGN 2 COPKINDREASSIGN 3 COPKINDCONNECT 4 COPKINDRECONNECT 5 COPKINDSTART 6 COPKINDCONTINUE 7 COPKINDABORT 8 COPKINDLOGOFF 9 COPKINDTEST 10 COPKINDCONFIG 11 COPKINDAUTHMETHOD 12 COPKINDSSOREQ 13 COPKINDELICITDATA 255 COPKINDDIRECT ); our @ebcdics = ( ((0) x 64), 1, ((0) x 9), ((1) x 5), 0, 1, ((0) x 9), ((1) x 8), ((0) x 8), ((1) x 6), ((0) x 10), ((1) x 6), 0, ((1) x 9), ((0) x 7), ((1) x 9), ((0) x 7), ((1) x 9), 0,0,0,1, ((0) x 15), 1,0,0, ((1) x 10), ((0) x 6), ((1) x 10), ((0) x 6), 1, 0, ((1) x 8), ((0) x 6), ((1) x 10), ((0) x 6) ); sub io_hexdump { my ($hdr, $buf) = @_; my $i = 0; my $hexbuf = ''; my $alphabuf = ''; my $cval = ''; my $outstr = $hdr . ":\n"; for ($i = 0; $i < length($buf); $i++) { $outstr .= "$hexbuf $alphabuf\n", $hexbuf = '', $alphabuf = '' if ($i%16 == 0); $hexbuf .= ' ' . unpack('H2', substr($buf, $i, 1)); $cval = unpack('C', substr($buf, $i, 1)); $alphabuf .= ((($cval > 127) || ($cval < 32)) ? '.' : chr($cval)); } $outstr .= "$hexbuf $alphabuf\n" if (length($hexbuf) > 0); $outstr .= "\n"; return $outstr; } sub _fractime { my @t = split(/\./, time()); my $p = scalar localtime($t[0]); $p=~s/^\w+\s+(.+?)\s+\d+$/At $1.$t[1]/; return $p; } sub io_hdrdump { my ($hdr, $buf) = @_; my $i = 0; my $hexbuf = ''; my $alphabuf = ''; my $cval = ''; my ($req, $kind) = unpack('CC', substr($buf, 1, 2)); $req = ($req == 1) ? 'Sending' : 'Received'; $kind = $td_msgkind_map{$kind} || 'Unknown kind'; my ($seg, $len) = unpack('Cxxxn', substr($buf, 4, 6)); $len += ($seg << 16); my ($tdsess, $tdauth1, $tdauth2, $reqno) = unpack('N LL N', substr($buf, 20)); my $outstr = _fractime() . "\n$hdr $req $kind Session $tdsess Request $reqno: $len bytes:\n"; for ($i = 0; $i < length($buf); $i++) { $outstr .= "$hexbuf $alphabuf\n", $hexbuf = '', $alphabuf = '' if ($i%16 == 0); $hexbuf .= ' ' . unpack('H2', substr($buf, $i, 1)); $cval = unpack('C', substr($buf, $i, 1)); $alphabuf .= ((($cval > 127) || ($cval < 32)) ? '.' : chr($cval)); } $outstr .= "$hexbuf $alphabuf\n" if (length($hexbuf) > 0); return $outstr; } sub io_pcldump { my ($buf, $len, $encrypted) = @_; my $i = 0; my $hexbuf = ''; my $alphabuf = ''; my ($flavor, $pcllen) = (0,0); my $cval; my $outstr = ''; my $pos = 0; my $pclhdrsz = 4; my $aph = undef; while ($pos < $len) { $aph = "\n"; if ($encrypted) { $outstr .= "Encrypted Data:\n"; for ($i = 0; $i < $len; $i++) { $outstr .= "$hexbuf $alphabuf\n" , ($hexbuf, $alphabuf) = ('', '') if ($i%16 == 0); $hexbuf .= ' ' . unpack('H2', substr($buf, $pos + $i, 1)); $cval = unpack('C', substr($buf, $pos + $i, 1)); $alphabuf .= (($cval > 127) || ($cval < 32)) ? '.' : chr($cval); } $outstr .= "$hexbuf $alphabuf\n" if (length($hexbuf) > 0); $hexbuf = ''; $alphabuf = ''; $pos += $len; } else { ($flavor, $pcllen) = unpack('SS', substr($buf, $pos, 4)); $pclhdrsz = 4; $flavor &= 0x00FF, $aph = "\n(APH)", $pcllen = unpack('L', substr($buf, $pos+4, 4)), $pclhdrsz = 8 if ($flavor & 0x8000); $outstr .= ($flavor <= $#td_pclstrings) ? "$aph Parcel $td_pclstrings[$flavor] length $pcllen:\n" : "Unknown parcel $flavor length $pcllen:\n"; $pcllen -= $pclhdrsz; $pos += $pclhdrsz; for ($i = 0; $i < $pcllen; $i++) { $outstr .= "$hexbuf $alphabuf\n" , ($hexbuf, $alphabuf) = ('', '') if ($i%16 == 0); $hexbuf .= ' ' . unpack('H2', substr($buf, $pos + $i, 1)); $cval = unpack('C', substr($buf, $pos + $i, 1)); $alphabuf .= (($cval > 127) || ($cval < 32)) ? '.' : chr($cval); } $outstr .= "$hexbuf $alphabuf\n" if (length($hexbuf) > 0); $hexbuf = ''; $alphabuf = ''; $pos += $pcllen; } } return $outstr . "\n"; } 1;package DBD::Teradata::GetInfo; use strict; use DBD::Teradata; my $sql_driver = 'Teradata'; my $sql_driver_ver = '1.50'; my @Keywords = qw( ABORT ABORTSESSION ABS ACCESS ACCESS_LOCK ACCOUNT ACOS ACOSH ADD_MONTHS ADMIN AFTER AGGREGATE ALIAS ALLOCATION ALWAYS AMP ANALYSIS ANSIDATE ASCII ASIN ASINH ATAN ATAN2 ATANH ATOMIC ATTR ATTRIBUTES ATTRS AVE AVERAGE BEFORE BLOB BT BUT BYTE BYTEINT BYTES CALL CALLED CASESPECIFIC CASE_N CD CHANGERATE CHAR2HEXINT CHARACTERS CHARS CHARSET_COLL CHECKPOINT CHECKSUM CLASS CLOB CLUSTER CM COLLECT COLUMNSPERINDEX COMMENT COMPRESS CONVERT_TABLE_HEADER CORR COS COSH COSTS COVAR_POP COVAR_SAMP CS CSUM CT CUBE CV CYCLE DATA DATABASE DATABLOCKSIZE DATEFORM DBC DEGREES DEL DEMOGRAPHICS DENIALS DETERMINISTIC DIAGNOSTIC DIGITS DISABLED DO DUAL DUMP EACH EBCDIC ECHO ELSEIF ENABLED EQ ERROR ERRORFILES ERRORTABLES ET EXCL EXCLUSIVE EXIT EXP EXPIRE EXPLAIN FALLBACK FASTEXPORT FOLLOWING FORMAT FREESPACE FUNCTION GE GENERATED GIVE GRAPHIC GROUPING GT HANDLER HASH HASHAMP HASHBAKAMP HASHBUCKET HASHROW HELP HIGH HOST IF IFP INCONSISTENT INCREMENT INDEXESPERTABLE INITIATE INOUT INS INSTEAD INTEGERDATE ITERATE JIS_COLL JOURNAL KANJI1 KANJISJIS KBYTE KBYTES KEEP KILOBYTES KURTOSIS LATIN LE LEAVE LIMIT LN LOADING LOCATOR LOCK LOCKEDUSEREXPIRE LOCKING LOG LOGGING LOGON LONG LOOP LOW LT MACRO MATCHED MAVG MAXCHAR MAXIMUM MAXLOGONATTEMPTS MAXVALUE MCHARACTERS MDIFF MEDIUM MERGE MINCHAR MINDEX MINIMUM MINUS MINVALUE MLINREG MLOAD MOD MODE MODIFIED MODIFY MONITOR MONRESOURCE MONSESSION MSUBSTR MSUM MULTINATIONAL MULTISET NAME NAMED NE NEW NEW_TABLE NOWAIT NULLIFZERO OBJECTS OFF OLD OLD_TABLE ORDERED_ANALYTIC OUT OVER OVERRIDE PARAMETER PARTITION PARTITIONED PASSWORD PERCENT PERCENT_RANK PERM PERMANENT PRECEDING PRIVATE PROFILE PROPORTIONAL PROTECTED PROTECTION QUALIFIED QUALIFY QUANTILE QUERY RADIANS RANDOM RANDOMIZED RANGE RANGE_N RANK RECALC REFERENCING REGR_AVGX REGR_AVGY REGR_COUNT REGR_INTERCEPT REGR_R2 REGR_SLOPE REGR_SXX REGR_SXY REGR_SYY RELEASE RENAME REPEAT REPLACE REPLACEMENT REPLICATION REPOVERRIDE REQUEST RESTART RESTORE RESUME RET RETRIEVE RETURNS REUSE REVALIDATE RIGHTS ROLE ROLLFORWARD ROLLUP ROW ROWID ROW_NUMBER SAMPLE SAMPLEID SAMPLES SEARCHSPACE SEL SETRESRATE SETS SETSESSRATE SHARE SHOW SIN SINH SKEW SOUNDEX SPECCHAR SPECIFIC SPOOL SQLEXCEPTION SQLTEXT SQRT SS START STARTUP STAT STATEMENT STATISTICS STATS STDDEV_POP STDDEV_SAMP STEPINFO STRING_CS STYLE SUBSCRIBER SUBSTR SUMMARY SUSPEND SYSTEM SYSTEMTEST TAN TANH TBL_CS TD_GENERAL TERMINATE TEXT THRESHOLD TITLE TPA TRACE TRANSLATE_CHK TRIGGER TYPE UC UNBOUNDED UNDEFINED UNDO UNICODE UNTIL UPD UPPERCASE USE VARBYTE VARGRAPHIC VAR_POP VAR_SAMP VOLATILE WAIT WHILE WIDTH_BUCKET WITHOUT ZEROIFNULL ); sub sql_keywords { return join ',', @Keywords; } sub sql_data_source_name { my $dbh = shift; return "dbi:$sql_driver:" . $dbh->{Name}; } sub sql_server_name { my $dbh = shift; return $dbh->{Name}; } sub sql_dbms_ver { my $dbh = shift; return $dbh->{tdat_version}; } sub sql_charset { my $dbh = shift; return $dbh->{tdat_charset}; } sub sql_user_name { my $dbh = shift; return $dbh->{CURRENT_USER} || $dbh->{Username}; } our %info = ( 13 => \&sql_server_name, 18 => \&sql_dbms_ver, 20 => 'Y', 19 => 'N', 0 => 0, 116 => 0, 1 => 16, 169 => 127, 117 => 0, 86 => 3, 10021 => 2, 120 => 6, 121 => 11, 82 => 0, 114 => 0, 10003 => 'N', 41 => '', 42 => '', 92 => 0, 10004 => \&sql_charset, 87 => 'Y', 22 => 0, 53 => 0, 54 => 265217, 55 => 12569, 56 => 1832891, 57 => 33033, 58 => 1581503, 59 => 8639, 60 => 8639, 48 => 1, 173 => '-1', 61 => 1679807, 123 => 1073951, 124 => 549663, 71 => 265217, 62 => 1832891, 63 => 1581503, 64 => 8639, 65 => 1581503, 66 => 65961, 67 => 230145, 68 => 1581503, 69 => 265217, 70 => 1832891, 122 => '-1', 125 => '-1', 126 => '-1', 74 => 1, 127 => 0, 128 => 0, 129 => 0, 130 => 0, 131 => 7, 132 => '-1', 133 => 0, 134 => 3, 23 => 2, 24 => 2, 10001 => 1, 2 => \&sql_data_source_name, 25 => 'N', 119 => 65535, 17 => 'Teradata', 170 => 3, 26 => 8, 26 => 8, 10002 => '-256', 3 => 1, 4 => 1, 6 => $INC{'DBD/Teradata.pm'}, 77 => '03.52', 7 => $sql_driver_ver, 136 => 0, 137 => 0, 138 => 0, 139 => 0, 140 => 0, 141 => '-1', 142 => 0, 143 => '-1', 144 => 0, 145 => 0, 27 => 'Y', 8 => 1, 84 => 0, 146 => 0, 147 => 0, 81 => 11, 88 => 2, 28 => 4, 29 => '"', 148 => '-1', 149 => 0, 172 => '-1', 73 => 'Y', 150 => 0, 151 => 0, 89 => \&sql_keywords, 113 => 'Y', 78 => 1, 34 => 0, 97 => 0, 98 => 64, 99 => 0, 100 => 2048, 101 => 2048, 30 => 30, 1 => 16, 31 => 30, 0 => 0, 10005 => 30, 102 => 0, 104 => '-1280', 32 => 30, 105 => 1047500, 20000 => '-1', 20001 => '-1', 20002 => '-1', 106 => 0, 35 => 30, 107 => 30, 10022 => '-1', 112 => 62000, 34 => 0, 108 => 31000, 97 => 0, 98 => 64, 99 => 0, 100 => 2048, 101 => 2048, 30 => 30, 1 => 16, 31 => 30, 0 => 0, 10005 => 30, 102 => 0, 32 => 30, 33 => 30, 34 => 0, 104 => '-1280', 103 => '', 32 => 30, 105 => 1047500, 106 => 0, 35 => 30, 107 => 30, 37 => 'Y', 36 => 'Y', 111 => 'N', 75 => 1, 85 => 1, 49 => 85249, 9 => 2, 152 => 1, 12 => 1, 15 => 1, 73 => 'Y', 115 => 127, 90 => 'N', 38 => 'Y', 115 => 127, 39 => 'DATABASE', 91 => 31, 153 => 2, 154 => 2, 80 => 0, 79 => 1, 21 => 'Y', 40 => 'MACRO|PROCEDURE', 114 => 0, 41 => '', 42 => '', 92 => 0, 93 => 4, 11 => 'N', 39 => 'DATABASE', 91 => 31, 43 => 3, 44 => 1, 14 => '\\', 94 => '#$', 155 => 7, 156 => 0, 157 => 0, 158 => '-1', 159 => 63, 160 => '-1', 161 => '-1', 162 => 32144, 163 => 0, 164 => '-1', 165 => 15, 118 => '-1', 166 => 2, 167 => 0, 168 => 0, 83 => 0, 50 => 7229, 95 => 23, 51 => 1, 45 => 'TABLE', 109 => 351, 110 => 350, 52 => 2064383, 46 => 1, 72 => 9, 46 => 1, 72 => 9, 96 => 3, 96 => 3, 47 => \&sql_user_name, 10000 => '-256', ); 1; package DBD::Teradata::TypeInfo; require Exporter; require DynaLoader; our @ISA = qw(Exporter DynaLoader); our @EXPORT = qw(type_info_all); use DBI qw(:sql_types); our $type_info_all = [ { TYPE_NAME => 0, DATA_TYPE => 1, COLUMN_SIZE => 2, LITERAL_PREFIX => 3, LITERAL_SUFFIX => 4, CREATE_PARAMS => 5, NULLABLE => 6, CASE_SENSITIVE => 7, SEARCHABLE => 8, UNSIGNED_ATTRIBUTE => 9, FIXED_PREC_SCALE => 10, AUTO_UNIQUE_VALUE => 11, LOCAL_TYPE_NAME => 12, MINIMUM_SCALE => 13, MAXIMUM_SCALE => 14, SQL_DATA_TYPE => 15, SQL_DATETIME_SUB => 16, NUM_PREC_RADIX => 17, INTERVAL_PRECISION => 18, }, [ "BYTEINT", -6, 3, undef, undef, undef, 1,0,2,0, 0,0,"BYTEINT", 0, 0, -6, undef,10,undef, ], [ "VARBYTE", -3, 64000,"'", "'XB", "max length", 1,0,0,undef,0,0,"VARBYTE", undef,undef,-3,undef,0, undef, ], [ "BYTE", -2, 64000,"'", "'XB", "max length", 1,0,0,undef,0,0,"BYTE", undef,undef,-2, undef,0, undef, ], [ "CHAR", 1, 64000,"'", "'", "max length", 1,1,3,undef,0,0,"CHAR", undef,undef,1, undef,0, undef, ], [ "DECIMAL", 3, 18, undef, undef, "precision, scale",1,0,2,0, 0,0,"DECIMAL", 0, 18, 3, undef,10,undef, ], [ "INTEGER", 4, 10, undef, undef, undef, 1,0,2,0, 0,0,"INTEGER", 0, 0, 4, undef,10,undef, ], [ "SMALLINT", 5, 5, undef, undef, undef, 1,0,2,0, 0,0,"SMALLINT", 0, 0, 5, undef,10,undef, ], [ "FLOAT", 6, 15, undef, undef, undef, 1,0,2,0, 0,0,"FLOAT", undef,undef,6, undef,2, undef, ], [ "DATE", 91, 10, undef, undef, undef, 1,0,2,undef,0,0,"DATE", 0, 0, 9, 1, 0, undef, ], [ "TIME", 92, 8, undef, undef, undef, 1,0,2,undef,0,0,"TIME", 0, 0, 9, 2, 0, undef, ], [ "TIMESTAMP", 93, 26, "TIMESTAMP '","'", "scale", 1,0,2,undef,0,0,"TIMESTAMP", 0, 6, 9, 3, 0, undef, ], [ "VARCHAR", 12, 64000,"'", "'", "max length", 1,1,3,undef,0,0,"VARCHAR", undef,undef,12, undef,0, undef, ], [ "INTERVAL YEAR", 101, 4, "INTERVAL '", "' YEAR", "precision", 1,0,2,undef,0,0,"INTERVAL YEAR", undef,undef,10, 1, 0, 2, ], [ "INTERVAL MONTH", 102, 4, "INTERVAL '", "' MONTH", "precision", 1,0,2,undef,0,0,"INTERVAL MONTH", undef,undef,10, 2, 0, 2, ], [ "INTERVAL DAY", 103, 4, "INTERVAL '", "' DAY", "precision", 1,0,2,undef,0,0,"INTERVAL DAY", undef,undef,10, 3, 0, 2, ], [ "INTERVAL HOUR", 104, 4, "INTERVAL '", "' HOUR", "precision", 1,0,2,undef,0,0,"INTERVAL HOUR", undef,undef,10, 4, 0, 2, ], [ "INTERVAL MINUTE", 105, 4, "INTERVAL '", "' MINUTE", "precision", 1,0,2,undef,0,0,"INTERVAL MINUTE", undef,undef,10, 5, 0, 2, ], [ "INTERVAL SECOND", 106, 11, "INTERVAL '", "' SECOND", "precision, scale",1,0,2,undef,0,0,"INTERVAL SECOND", 0, 6, 10, 6, 0, 2, ], [ "INTERVAL YEAR TO MONTH", 107, 7, "INTERVAL '", "' YEAR TO MONTH", "precision", 1,0,2,undef,0,0,"INTERVAL YEAR TO MONTH", undef,undef,10, 7, 0, 2, ], [ "INTERVAL DAY TO HOUR", 108, 7, "INTERVAL '", "' DAY TO HOUR", "precision", 1,0,2,undef,0,0,"INTERVAL DAY TO HOUR", undef,undef,10, 8, 0, 2, ], [ "INTERVAL DAY TO MINUTE", 109, 10, "INTERVAL '", "' DAY TO MINUTE", "precision", 1,0,2,undef,0,0,"INTERVAL DAY TO MINUTE", undef,undef,10, 9, 0, 2, ], [ "INTERVAL DAY TO SECOND", 110, 20, "INTERVAL '", "' DAY TO SECOND", "precision", 1,0,2,undef,0,0,"INTERVAL DAY TO SECOND", 0, 6, 10, 10, 0, 2, ], [ "INTERVAL HOUR TO MINUTE", 111, 7, "INTERVAL '", "' HOUR TO MINUTE", "precision", 1,0,2,undef,0,0,"INTERVAL HOUR TO MINUTE", undef,undef,10, 11, 0, 2, ], [ "INTERVAL HOUR TO SECOND", 112, 17, "INTERVAL '", "' HOUR TO SECOND", "precision", 1,0,2,undef,0,0,"INTERVAL HOUR TO SECOND", 0, 6, 10, 12, 0, 2, ], [ "INTERVAL MINUTE TO SECOND",113,14, "INTERVAL '", "' MINUTE TO SECOND","precision", 1,0,2,undef,0,0,"INTERVAL MINUTE TO SECOND",0, 6, 10, 13, 0, 2, ], ]; 1; package DBD::Teradata::Cli; use Time::HiRes qw(time sleep); use Exporter; BEGIN { our @ISA = qw(Exporter); our @EXPORT = (); our @EXPORT_OK = (); our %EXPORT_TAGS = ( tdcli_errors => [ ], ); Exporter::export_tags(keys %EXPORT_TAGS); } our $VERSION = '1.52'; use strict; use warnings; our %dbc_ctxts = (); sub CLONE { map { $_->[1] = 0; } values %dbc_ctxts; %dbc_ctxts = (); } sub new { my ($class, $logonstr, $mode, $logonsrc, $charset, $debug) = @_; my $obj = [ ]; bless $obj, $class; my ($errno, $errstr, $dbc, $hostid, $sessno, $version) = (0, '', undef, undef, undef, undef); print "cli_connect: initing\n" if $debug; $dbc = tdxs_init_dbcarea($debug); return (undef, -1, "Cannot init dbcarea") unless $dbc; $obj->[4] = $debug; print "cli_connect: connecting $logonstr\n" if $debug; my $partition = 'DBC/SQL '; my $lsn = 0; my $runstring = pack('A16 L S S', $partition, 0, 0, 0); ($sessno, $hostid, $version, $lsn, $errno, $errstr) = tdxs_get_connection($dbc, $logonstr, $mode, $runstring, $logonsrc, $charset); unless ($errno) { $obj->[1] = $dbc; print "cli_connect: connected\n" if $debug; $obj->[5] = $sessno; $dbc_ctxts{"$sessno\_$$"} = $obj; return ($obj, undef, undef, $hostid, $sessno, $version); } print "cli_connect: didn't connect: $errstr\n" if $debug; return ($obj, $errno, $errstr, undef, undef, undef, undef); } sub cli_get_tdat_release { return tdxs_get_tdat_release($_[0]->[1]); } sub cli_set_debug { tdxs_set_debug($_[0]->[1], $_[1]); $_[0]->[4] = $_[1]; } sub cli_disconnect { my ($err, $errstr); $err = tdxs_cleanup($_[0]->[1], $errstr) if $_[0]->[1]; $_[0]->[3] = undef; $_[0]->[1] = undef; delete $dbc_ctxts{$_[0]->[5] . "_$$"}; 1; } sub cli_test_leak { my $sql = 'sel user,date,time' . (' ' x 4000); my $req = pack('a* SSa10 SS a* SS S', "\0" x 52, 85, 14, 'RE', 1, 4 + length($sql), $sql, 4, 4 + 2, 64000); tdxs_test_leak($_[0]->[1], $req, $_[1]); } sub cli_send_request { my $obj = shift; print "cli_send_request: sending\n" if $obj->[4]; my ($reqid, $err, $errstr) = tdxs_send_request($obj->[1], @_); print "cli_send_request: request $reqid sent\n" unless $err || (! $obj->[4]); $obj->[2] = $reqid unless $err; return ($reqid, $err, $errstr); } sub cli_has_response { my ($obj, $wait) = @_; print "cli_has_response: checking for response\n" if $obj->[4]; my $buffer; unless (defined($obj->[2])) { print "cli_has_response: session not active\n" if $obj->[4]; return undef; } if (defined($obj->[3])) { print "cli_has_response: return old response for $obj->[2]\n" if $obj->[4]; return $obj->[3]->[3]; } my $reqid = $obj->[2]; my ($err, $errstr) = $obj->cli_get_response(\$buffer, $reqid, undef, $wait); if ($err && ($err == 211)) { print "cli_has_response: no response for $reqid\n" if $obj->[4]; return undef; } print "cli_has_response: got a response for $reqid\n" if $obj->[4]; $obj->[3] = [ $err, $errstr, $buffer, $reqid ]; return $reqid; } sub cli_get_response { my ($obj, $buffer, $reqid, $keepresp, $wait) = @_; my ($err, $errstr); my $debug = $obj->[4]; print 'cli_get_response: getting ', ($keepresp ? 'KEEPRESP' : 'RESP'), " response for $reqid\n" if $debug; return (208, '208: No data received from dbc.') if ($obj->[2] && ($obj->[2] != $reqid)); if ($obj->[3] && ($obj->[3]->[3] == $reqid)) { print "cli_get_response: returning stored response\n" if $debug; ($err, $errstr, $$buffer, $reqid) = @{$obj->[3]}; $obj->[3] = undef; return ($err, $errstr); } print "cli_get_response: getting response\n" if $debug; unless ($wait) { ($err, $errstr) = tdxs_get_response($obj->[1], $$buffer, $reqid, $keepresp, $wait); $obj->[2] = $reqid if ($err && ($err == 211)); print "cli_get_response: got response length ", length($$buffer), "\n" unless ($err || (! $debug)); return ($err, $errstr); } my $started = time(); while (($wait < 0) || ((time() - $started) < $wait)) { ($err, $errstr) = tdxs_get_response($obj->[1], $$buffer, $reqid, $keepresp, ($wait < 0)); last unless (($err == 211) || ($err == 208)); } $obj->[2] = $reqid if ($err && ($err == 211)); print "cli_get_response: got response length ", length($$buffer), "\n" unless ($err || (! $debug)); return ($err, $errstr); } sub cli_end_request { my ($obj, $reqid) = @_; print "cli_end_request: Ending request $reqid\n" if $obj->[4]; my ($err, $errstr) = tdxs_end_request($obj->[1], $reqid); ($err, $errstr) = (0, undef) if ($err == 305); print "end_request failed: $err $errstr\n" if ($obj->[4] && $err); $obj->[3] = undef if ($obj->[3] && ($obj->[3]->[3] == $reqid)); $obj->[2] = undef if ($obj->[2] && ($obj->[2] == $reqid)); return ($err, $errstr) } sub cli_abort_request { print "cli_abort_request: Aborting request $_[1]\n" if $_[0]->[4]; return tdxs_abort_request($_[0]->[1], $_[1]); } sub cli_wait_for_response { my $timeout = shift; my $started = time(); my @ready = (); my ($id, $obj, $reqid, $keepresp); while ((!defined($timeout)) || ($timeout > (time() - $started))) { my $i = 0; while ($i < scalar @_) { my $buffer; ($id, $obj, $reqid, $keepresp) = @_[$i .. $i + 3]; my ($err, $errstr) = tdxs_get_response($obj->[1], $buffer, $reqid, $keepresp, undef); next if ($err && ($err == 211)); print 'cli_has_response: got a response for ', $reqid, "\n" if $obj->[4]; push @ready, $id; $obj->[3] = [ $err, $errstr, $buffer, $reqid ]; $i += 4; } return @ready if scalar @ready; select(undef, undef, undef, 0.05); } return (); } sub DESTROY { my ($err, $errstr); return 1 unless $dbc_ctxts{$_[0]->[5] . "_$$"}; $err = tdxs_cleanup($_[0]->[1], $errstr) if $_[0]->[1]; $_[0]->[3] = undef; $_[0]->[1] = undef; delete $dbc_ctxts{$_[0]->[5] . "_$$"}; } require XSLoader; XSLoader::load('DBD::Teradata', $VERSION); 1;