/* Copyright (c) 1997-2007, Perforce Software, Inc. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL PERFORCE SOFTWARE, INC. BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ #include "perlheaders.h" // Undef conflicting macros defined by Perl #undef Error #undef Null #undef Stat #undef Copy #include "clientapi.h" #include "strtable.h" #include "debug.h" #include "p4perldebug.h" #include "perlclientapi.h" /* * The architecture of this extension is relatively complex. The main Perl * class is P4 which is a blessed scalar containing pointers to our C++ * objects which hold all our real data. We try to expose as little as * possible of the internals to Perl. * * As the Perforce API is callback based, we have some tap-dancing to do * in order to shim it into Perl space. There are two main C++ classes: * * 1 PerlClientUser is our subclass of the Perforce ClientUser class. This * class handles all the user-interface functions needed in the API - i.e. * getting input, writing output/errors etc. * * 2. PerlClientApi is our interface to the Perforce ClientApi class. It * provides a type-bridge between Perl and C++ and makes sure * that the results it returns are ready for use in Perl space. * * This module provides the glue between Perl space and C++ space by * providing Perl methods that call the C++ methods and return the appropriate * results. */ #define CLIENT_PTR_NAME "_p4client_ptr" static PerlClientApi * ExtractClient( SV *var ) { if (!(sv_isobject((SV*)var) && sv_derived_from((SV*)var,"P4"))) { warn("Not a P4 object!" ); return 0; } HV * h = (HV *)SvRV( var ); SV ** c = hv_fetch( h, CLIENT_PTR_NAME, strlen( CLIENT_PTR_NAME ),0); if( !c ) { warn( "No '" CLIENT_PTR_NAME "' member found in P4 object!" ); return 0; } return INT2PTR( PerlClientApi *, SvIV( *c ) ); } MODULE = P4 PACKAGE = P4 VERSIONCHECK: DISABLE PROTOTYPES: DISABLE SV * new( CLASS ) char *CLASS; INIT: SV * iv; HV * myself; HV * stash; PerlClientApi * c; CODE: /* * Create a PerlClientApi object and stash a pointer to it * in an HV. */ c = new PerlClientApi(); iv = newSViv( PTR2IV( c ) ); myself = newHV(); hv_store( myself, CLIENT_PTR_NAME, strlen( CLIENT_PTR_NAME ), iv, 0 ); /* Return a blessed reference to the HV */ RETVAL = newRV_noinc( (SV *)myself ); stash = gv_stashpv( CLASS, TRUE ); sv_bless( (SV *)RETVAL, stash ); OUTPUT: RETVAL void DESTROY( THIS ) SV *THIS INIT: PerlClientApi *c; CODE: c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; delete c; SV * Identify() CODE: RETVAL = PerlClientApi::Identify(); OUTPUT: RETVAL SV * Dropped( THIS ) SV *THIS INIT: PerlClientApi *c; CODE: c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; RETVAL = c->Dropped(); OUTPUT: RETVAL void Disconnect( THIS ) SV *THIS INIT: PerlClientApi * c; CODE: c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; c->Disconnect(); SV * GetClient( THIS ) SV *THIS INIT: PerlClientApi* c; CODE: c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; RETVAL = c->GetClient(); OUTPUT: RETVAL SV * GetCwd( THIS ) SV *THIS INIT: PerlClientApi * c; CODE: c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; RETVAL = c->GetCwd(); OUTPUT: RETVAL SV * GetHost( THIS ) SV *THIS INIT: PerlClientApi * c; CODE: c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; RETVAL = c->GetHost(); OUTPUT: RETVAL SV * GetLanguage( THIS ) SV *THIS INIT: PerlClientApi * c; CODE: c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; RETVAL = c->GetLanguage(); OUTPUT: RETVAL SV * GetPassword( THIS ) SV *THIS INIT: PerlClientApi * c; CODE: c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; RETVAL = c->GetPassword(); OUTPUT: RETVAL SV * GetPort( THIS ) SV *THIS INIT: PerlClientApi * c; CODE: c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; RETVAL = c->GetPort(); OUTPUT: RETVAL SV * GetCharset( THIS ) SV *THIS INIT: PerlClientApi * c; CODE: c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; RETVAL = c->GetCharset(); OUTPUT: RETVAL SV * GetUser( THIS ) SV *THIS INIT: PerlClientApi * c; CODE: c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; RETVAL = c->GetUser(); OUTPUT: RETVAL SV * Connect( THIS ) SV *THIS INIT: PerlClientApi * c; CODE: c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; RETVAL = c->Connect(); OUTPUT: RETVAL SV * _Run( THIS, cmd, ... ) SV *THIS SV *cmd INIT: PerlClientApi * c; I32 va_start = 2; I32 debug = 0; I32 argc; I32 stindex; I32 argindex; STRLEN len = 0; char * currarg; char ** cmdargs = NULL; SV * sv; CODE: c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; debug = c->GetDebugLevel(); /* * First check that the client has been initialised. Otherwise * the result tends to be a SEGV */ if ( !c->IsConnected() ) { warn("P4::Run() - Not connected. Call P4::Connect() first" ); XSRETURN_UNDEF; } if ( P4PERL_DEBUG_CMDS ) printf( "[P4::Run] Running a \"p4 %s\" with %d args\n", SvPV_nolen( cmd ), items - va_start ); if ( items > va_start ) { argc = items - va_start; New( 0, cmdargs, argc, char * ); for ( stindex = va_start, argindex = 0; argc; argc--, stindex++, argindex++ ) { if ( SvPOK( ST(stindex) ) ) { currarg = SvPV( ST(stindex), len ); cmdargs[argindex] = currarg ; } else if ( SvIOK( ST(stindex) ) ) { /* * Be friendly and convert numeric args to * char *'s. Use Perl to reclaim the storage. * automatically by declaring them as mortal SV's */ char buf[32]; STRLEN len; sprintf(buf, "%d", SvIV( ST( stindex ) ) ); sv = sv_2mortal(newSVpv( buf, 0 )); currarg = SvPV( sv, len ); cmdargs[argindex] = currarg; } else if( SvTYPE( ST(stindex) ) == SVt_PVLV ) { /* * In theory, this is tainted data */ warn( "Argument %d to P4::Run() is tainted!",argindex ); } else { /* * Can't handle other arg types */ printf( "\tArg[ %d ] unknown type %d\n", argindex, SvTYPE( ST(stindex) ) ); warn( "Invalid argument to P4::Run. Aborting command" ); XSRETURN_UNDEF; } } } len = 0; currarg = SvPV( cmd, len ); if ( P4PERL_DEBUG_CMDS ) { for ( int i = 0; i < items - va_start; i++ ) printf("[P4::Run] Arg[%d] = %s\n", i, cmdargs[i] ); } RETVAL = c->Run( currarg, items - va_start, cmdargs ); if ( cmdargs )Safefree( cmdargs ); OUTPUT: RETVAL SV * DebugLevel( THIS, ... ) SV * THIS INIT: PerlClientApi * c; I32 va_start = 1; int level = 0; CODE: c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; if( items > va_start ) { // Setting the debug level if( !SvIOK( ST( va_start ) ) ) { warn( "DebugLevel must be an integer" ); XSRETURN_UNDEF; } level = SvIV( ST( va_start ) ); c->SetDebugLevel( level ); } RETVAL = newSViv( c->GetDebugLevel() ); OUTPUT: RETVAL void Errors( THIS ) SV * THIS INIT: PerlClientApi * c; AV * a; SV ** s; int i; PPCODE: c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; a = c->GetErrors(); for( i = 0; i <= av_len( a ); i++ ) { s = av_fetch( a, i, 0); if( !s ) continue; XPUSHs( *s ); } I32 ErrorCount( THIS ) SV * THIS INIT: PerlClientApi * c; CODE: c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; RETVAL = c->GetErrorCount(); OUTPUT: RETVAL SV * FormatSpec( THIS, type, hash ) SV * THIS SV * type SV * hash INIT: PerlClientApi * c; HV * h; CODE: c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; if( SvROK( hash ) ) hash = SvRV( hash ); if( SvTYPE( hash ) == SVt_PVHV ) { h = (HV*) hash; } else { printf( "Type is: %d\n", SvTYPE( hash ) ); warn( "Argument to FormatSpec must be hashref" ); XSRETURN_UNDEF; } RETVAL = c->FormatSpec( SvPV( type, PL_na ), h ); OUTPUT: RETVAL I32 IsParseForms( THIS ) SV * THIS INIT: PerlClientApi *c; CODE: c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; RETVAL = c->IsParseForms(); OUTPUT: RETVAL I32 IsTagged( THIS ) SV * THIS INIT: PerlClientApi *c; CODE: c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; RETVAL = c->IsTagged(); OUTPUT: RETVAL SV * MergeErrors( THIS, ... ) SV * THIS INIT: PerlClientApi * c; I32 va_start = 1; int merge = -1; CODE: c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; if( items > va_start ) { // Setting the merge flag if( !SvIOK( ST( va_start ) ) ) { warn( "Argument to MergeErrors() must be an integer" ); XSRETURN_UNDEF; } merge = SvIV( ST( va_start ) ); } RETVAL = c->MergeErrors( merge ); OUTPUT: RETVAL void ParseForms( THIS ) SV * THIS INIT: PerlClientApi *c; CODE: c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; c->ParseForms(); SV * ParseSpec( THIS, type, buf ) SV * THIS SV * type SV * buf INIT: PerlClientApi *c; CODE: c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; RETVAL = c->ParseSpec( SvPV( type, PL_na ), SvPV( buf, PL_na ) ); OUTPUT: RETVAL SV * ServerLevel( THIS ) SV * THIS INIT: PerlClientApi *c; CODE: c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; RETVAL = c->GetServerLevel(); OUTPUT: RETVAL void SetApiLevel( THIS, level ) SV * THIS SV * level INIT: PerlClientApi *c; CODE: if( !SvIOK( level ) ) { warn( "API level must be an integer" ); XSRETURN_UNDEF; } c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; c->SetApiLevel( SvIV( level ) ); void SetCharset( THIS, charset ) SV * THIS char * charset INIT: PerlClientApi *c; CODE: c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; c->SetCharset( charset ); void SetClient( THIS, clientName ) SV *THIS char *clientName INIT: PerlClientApi * c; CODE: c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; c->SetClient( clientName ); void _SetCwd( THIS, cwd ) SV * THIS char * cwd INIT: PerlClientApi * c; CODE: c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; c->SetCwd( cwd ); void SetHost( THIS, hostname ) SV * THIS char * hostname INIT: PerlClientApi * c; CODE: c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; c->SetHost( hostname ); void SetInput( THIS, value ) SV * THIS SV * value INIT: PerlClientApi * c; CODE: c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; c->SetInput( value ); void SetMaxResults( THIS, value ) SV * THIS int value INIT: PerlClientApi * c; CODE: c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; c->SetMaxResults( value ); void SetMaxScanRows( THIS, value ) SV * THIS int value INIT: PerlClientApi * c; CODE: c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; c->SetMaxScanRows( value ); void SetPassword( THIS, password ) SV * THIS char * password INIT: PerlClientApi * c; CODE: c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; c->SetPassword( password ); void SetPort( THIS, address ) SV * THIS char * address INIT: PerlClientApi *c; CODE: c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; c->SetPort( address ); void SetProg( THIS, name ) SV * THIS char * name INIT: PerlClientApi *c; CODE: c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; c->SetProg( name ); void SetProtocol( THIS, protocol, value ) SV * THIS char * protocol char * value INIT: PerlClientApi *c; CODE: c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; c->SetProtocol( protocol, value ); void SetUser( THIS, username ) SV * THIS char * username INIT: PerlClientApi * c; CODE: c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; c->SetUser( username ); void Tagged( THIS ) SV * THIS INIT: PerlClientApi *c; CODE: c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; c->Tagged(); SV * WarningCount( THIS ) SV * THIS INIT: PerlClientApi * c; CODE: c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; RETVAL = newSViv( c->GetWarningCount() ); OUTPUT: RETVAL void Warnings( THIS ) SV * THIS INIT: PerlClientApi * c; AV * a; SV ** s; int i; PPCODE: c = ExtractClient( THIS ); if( !c ) XSRETURN_UNDEF; a = c->GetWarnings(); for( i = 0; i <= av_len( a ); i++ ) { s = av_fetch( a, i, 0); if( !s ) continue; XPUSHs( *s ); }
# | Change | User | Description | Committed | |
---|---|---|---|---|---|
#16 | 5868 | Tony Smith |
Port P4Perl to Perl 5.8.8. This change is spectacularly ugly, but then so are the innards of Perl. See the long thread at: http://www.nntp.perl.org/group/perl.perl5.porters/2006/06/msg114383.html for details of the problem, and some discussion of solutions. I've had to come up with a solution that doesn't involve patching people's Perl installations, so my fix is even less easy on the eye but it appears to work, and hopefully hasn't broken things for older Perl versions. |
||
#15 | 5708 | Tony Smith |
Add static P4::Identify() method to report the version of P4Perl, and the API used to build it. |
||
#14 | 5692 | Tony Smith |
Add support for $p4->ServerLevel() which returns the server's 'server2' protocol level. This is not the same as, but is closely aligned to, the server version and can be used to test for feature availability. If you need explicit Perforce version strings, run 'p4 info' in tagged mode and parse the 'serverVersion' string. New feature requested by Robert Cowham. |
||
#13 | 5396 | Tony Smith |
x86_64 porting changes. Use INT2PTR and PTR2INT to handle the stashing of the PerlClientApi pointer in a Perl scalar. This is necessary because, despite all documentation to the contrary, an I32 is not 64-bit capable on all 64-bit machines. Also, the hints file now looks for x86_64 in the architecture name and if it finds it, then const_char='const char' rather than the default of 'char'. |
||
#12 | 5313 | Tony Smith |
Add new SetApiLevel() method to allow users to lock scripts to a particular API level. This helps when upgrading to new servers that extend support for tagged output to hitherto unsupported commands (2005.2 did a lot of that). See the C/C++ API Release Notes for the full details, but by way of example, to lock scripts to the 2005.1 interface use: $p4->SetApiLevel( 57 ); |
||
#11 | 5067 | Tony Smith |
Bug fix: P4::SetProg() interface method was missing so SetProg wasn't working too well! |
||
#10 | 5038 | Tony Smith |
Bug fix: Fix memory leaks in P4Perl reported by Craig Galley. Perl's reference count garbage collection is not much fun to work with, but hopefully this change plugs P4Perl's leaks. There's still a leak that remains, but whether it's in P4Perl's code or just in Perl I don't know. A loop like this: while( 1 ) { my $p4 = new P4; } will leak like a sieve but I'm pretty sure P4Perl is cleaning up as it should. While it's very difficult to be certain with Perl's memory mode, creating one P4 object and using it multiple times now appears to be pretty steady. Also fixed use of uninitialized debug variable which could produce debug output you hadn't asked for. |
||
#9 | 4864 | Tony Smith |
Bug fix: Introduce workaround for obscure 2000.1/2000.2 protocol bug that I really thought we'd seen the last of. Along the way, a total revamp of the debugging output - required to diagnose the problem. |
||
#8 | 4856 | Tony Smith |
Rework P4::Errors() and P4::Warnings() so that they return a list rather than an array. Perl seems to like this more and it's easy to assign the list to an array should you wish to do so. Note that this may cause some backwards-compatibility issues. |
||
#7 | 4831 | Tony Smith |
Change implementation of P4 class from being a blessed reference to an integer (pointer) to a blessed reference to a hash. The pointer is now stashed in a member of the hash. This makes it easier for those that want to to subclass the P4 class and bolt on their own functionality. No functional change. |
||
#6 | 4804 | Tony Smith |
Add support for P4::SetMaxResults() and P4::SetMaxScanRows() which specify the desired limits for an instance of the P4 class. Note that the limits remain in force until disabled by setting them to zero. |
||
#5 | 4676 | Tony Smith |
Enable P4Perl to work against a server in unicode mode. This change adds two new methods to the P4 class: SetCharset() and GetCharset() which have the expected behaviour. Thanks to Raymond Danks <raymond.danks@amd.com>. Also cleaned up the test harness a little. |
||
#4 | 4666 | Tony Smith |
New ParseSpec() and FormatSpec() methods allow you to convert specs between hash and string representations easily. Shortcut methods Parse* and Format* are also defined. (i.e. FormatClient() and ParseLabel() etc.) New methods IsTagged() and IsParseForms() tell you if your client is in tagged/form parsing mode respectively. If you care. P4::Tag() is deprecated in favour of P4::Tagged(). P4::Tag() exists for backwards compatibility |
||
#3 | 4608 | Tony Smith |
Bug fix: The SetInput() method was omitted in the big rewrite so quite a lot was broken in builds 3.4579 and later. This change fixes that omission, and adds support for 'p4 login' too (that was how I discovered that SetInput() was missing). |
||
#2 | 4582 | Tony Smith |
Port new P4Perl architecture to Windows. Fixes a few porting issues and a couple of minor errors in the previous change. |
||
#1 | 4579 | Tony Smith |
Rewrite P4Perl to be more like P4Ruby. This change does away with the old P4/P4::Client split and pulls all the functionality of P4::Client into P4. Hence P4::Client is now deprecated. There are a few gotcha's - see the Changes file, and documentation for the details, but in general it's backwards compatible. As part of this change, I'm also releasing the previous current versions of P4 and P4::Client as released versions - for posterity. P4 now gets a v3.x version number so the old versions will stand out clearly. Hopefully it's all working - works fine for me - but people should consider this a beta build, for now at least. |