perlclientapi.cc #5

/*******************************************************************************
Copyright (c) 2001-2008, 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.
*******************************************************************************/


#ifdef OS_NT
# define WIN32_LEAN_AND_MEAN
# include <windows.h>
# include <winsvc.h>
# include <ntservice.h>
# undef GetMessage
# undef SetPort
#endif // OS_NT

#define NEED_TIME
#include "clientapi.h"
#include "hostenv.h"
#include "strtable.h"
#include "debug.h"
#include "spec.h"
#include "enviro.h"
#include "ident.h"
#include "i18napi.h"
#include "perlheaders.h"
#include "p4result.h"
#include "p4perldebug.h"
#include "specmgr.h"
#include "perlclientuser.h"
#include "perlclientapi.h"

static Ident ident = {
    IdentMagic "P4PERL" "/" ID_OS "/" ID_REL "/" ID_PATCH " (" ID_API " API)",
    ID_Y "/" ID_M "/" ID_D
};

SV *
PerlClientApi::Identify()
{
    StrBuf	msg;

    ident.GetMessage( &msg );

    // Not mortal, XS will do that for us.
    SV * sv = newSVpv( msg.Text(), msg.Length() );

    return sv;
}

PerlClientApi::PerlClientApi()
{
    client	= new ClientApi;
    specMgr	= new SpecMgr;
    ui 		= new PerlClientUser( specMgr );
    enviro	= new Enviro();
    initCount 	= 0;
    debug	= 0;
    maxResults	= 0;
    maxScanRows = 0;
    maxLockTime = 0;
    server2	= 0;
    caseSensitive = 1;	// Default is case-sensitive
    apiLevel	= atoi( P4Tag::l_client );
    tagged	= 1;
    prog	= "Unnamed P4Perl script";

    client->SetProtocol( "specstring", "" );

    //
    // Load any P4CONFIG file
    //
    HostEnv 	henv;
    StrBuf	cwd;

    henv.GetCwd( cwd, enviro );
    if( cwd.Length() )
	enviro->Config( cwd );


    //
    // Load the current ticket file. Start with the default, and then
    // override it if P4TICKETS is set.
    //
    const char *t;

    henv.GetTicketFile( ticketFile, enviro );
    
    if( t = enviro->Get( "P4TICKETS" ) )
	ticketFile = t;

    //
    // Load the current P4CHARSET if set.
    //
    if( client->GetCharset().Length() )
	SetCharset( client->GetCharset().Text() );
}

PerlClientApi::~PerlClientApi()
{
    Disconnect();
    delete ui;
    delete client;
    delete specMgr;
    delete enviro;
}

SV *
PerlClientApi::Connect()
{
    Error	e;

    if( initCount )
	return &PL_sv_yes;

    if( P4PERL_DEBUG_CMDS )
	PerlIO_stdoutf( "[P4]: Connecting to Perforce\n" );

    // Reset case-sensitivity, and reset server2 value also
    caseSensitive = 1;
    server2 = 0;

    client->Init( &e );
    if( e.Test() )
	ui->HandleError( &e );
    else
	initCount++;

    return initCount ? &PL_sv_yes : &PL_sv_no;
}

SV *
PerlClientApi::Disconnect()
{
    if( !initCount )
	return &PL_sv_yes;

    if( P4PERL_DEBUG_CMDS )
	PerlIO_stdoutf( "[P4]: Closing connection to Perforce\n" );

    Error e;
    client->Final( &e );
    initCount--;

    if( e.Test() ) 
	ui->HandleError( &e );
    return e.Test() ? &PL_sv_no : &PL_sv_yes;
}

int
PerlClientApi::IsConnected()
{
    if( initCount && !client->Dropped() )
	return 1;
    else if( client->Dropped() )
	Disconnect();
    return 0;
}

void
PerlClientApi::SetInput( SV *i )
{ 
    if( P4PERL_DEBUG_FLOW )
    	PerlIO_stdoutf( "Saving user input for later\n" );

    ui->SetInput( i );	     
}

void
PerlClientApi::SetApiLevel( int level )
{
    StrBuf	l;
    l << level;
    apiLevel = level;
    client->SetProtocol( "api", l.Text() );
}

SV *
PerlClientApi::SetCharset( const char *c )
{
    CharSetApi::CharSet	cs = CharSetApi::Lookup( c );
    if( cs == (CharSetApi::CharSet) -1 )
    {
	warn( "Unknown charset ignored. Check your code or P4CHARSET." );
	return &PL_sv_undef;
    }
    client->SetTrans( cs, cs, cs, cs );
    client->SetCharset( c );
    return &PL_sv_yes;
}

void
PerlClientApi::SetCwd( const char *c )
{
    client->SetCwd( c );
    enviro->Config( StrRef( c ) );
}

void
PerlClientApi::SetProtocol( const char *var, const char *val )
{
    client->SetProtocol( var, val );
}

SV *
PerlClientApi::GetApiLevel()
{
    return newSViv( apiLevel );
}


SV *
PerlClientApi::GetCharset()
{
    const StrPtr &c = client->GetCharset();
    return newSVpv( c.Text(), c.Length() );
}

SV *
PerlClientApi::GetConfig()
{
    const StrPtr &c = client->GetConfig();
    return newSVpv( c.Text(), c.Length() );
}

SV *
PerlClientApi::GetClient()
{
    const StrPtr &c = client->GetClient();
    return newSVpv( c.Text(), c.Length() );
}


SV *
PerlClientApi::GetCwd()
{
    const StrPtr &c = client->GetCwd();
    return newSVpv( c.Text(), c.Length() );
}


SV *
PerlClientApi::GetEnv( const char *var )
{
    char *val = enviro->Get( var );
    if( val )
	return newSVpv( val, 0 );
    return &PL_sv_undef;
}

SV *
PerlClientApi::GetHost()
{
    const StrPtr &c = client->GetHost();
    return newSVpv( c.Text(), c.Length() );
}


SV *
PerlClientApi::GetLanguage()
{
    const StrPtr &c = client->GetLanguage();
    return newSVpv( c.Text(), c.Length() );
}

SV *
PerlClientApi::GetMaxResults()
{
    return newSViv( maxResults );
}

SV *
PerlClientApi::GetMaxScanRows()
{
    return newSViv( maxScanRows );
}

SV *
PerlClientApi::GetMaxLockTime()
{
    return newSViv( maxLockTime );
}


SV *
PerlClientApi::GetPassword()
{
    const StrPtr &c = client->GetPassword();
    return newSVpv( c.Text(), c.Length() );
}


SV *
PerlClientApi::GetPort()
{
    const StrPtr &c = client->GetPort();
    return newSVpv( c.Text(), c.Length() );
}

SV *
PerlClientApi::GetProg()
{
    return newSVpv( prog.Text(), prog.Length() );
}

SV *
PerlClientApi::GetVersion()
{
    return newSVpv( version.Text(), version.Length() );
}

int
PerlClientApi::GetServerLevel()
{
    return server2;
}

void
PerlClientApi::SetTicketFile( const char *t )
{
    client->SetTicketFile( t );
    ticketFile = t;
}

SV *
PerlClientApi::GetTicketFile()
{
    return newSVpv( ticketFile.Text(), ticketFile.Length() );
}

SV *
PerlClientApi::GetUser()
{
    const StrPtr &c = client->GetUser();
    return newSVpv( c.Text(), c.Length() );
}

SV *
PerlClientApi::GetFirstOutput()
{
    AV * output = ui->GetResults().GetOutput();
    SV **s = av_fetch( output, 0, 0 );
    return s ? *s : 0;
}

AV *
PerlClientApi::GetOutput()
{
    return ui->GetResults().GetOutput();
}

AV *
PerlClientApi::GetWarnings()
{
    return ui->GetResults().GetWarnings();
}

AV *
PerlClientApi::GetErrors()
{
    return ui->GetResults().GetErrors();
}

I32
PerlClientApi::GetOutputCount()
{
    return ui->GetResults().OutputCount();
}

I32
PerlClientApi::GetWarningCount()
{
    return ui->GetResults().WarningCount();
}

I32
PerlClientApi::GetErrorCount()
{
    return ui->GetResults().ErrorCount();
}

void
PerlClientApi::SetDebugLevel( int l )
{
    debug = l;
    ui->SetDebugLevel( l );
    specMgr->SetDebug( l );
    if( P4PERL_DEBUG_RPC )
	p4debug.SetLevel( DT_RPC, 5 );
    else
	p4debug.SetLevel( DT_RPC, 0 );
}

void
PerlClientApi::SetResolver( SV * r )
{
    ui->SetResolver( r );
}


AV *
PerlClientApi::Run( const char *cmd, int argc, char * const *argv )
{
    StrBuf cmdstr;

    ui->Reset();

    if( P4PERL_DEBUG_CMDS )
    {
	cmdstr << cmd;
	char * const *a = argv;
	for( int i = 0; i < argc; i++, a++ )
	    cmdstr << " " << *a;

	PerlIO_stdoutf( "[P4]: Executing: 'p4 %s'\n", cmdstr.Text() );
    }

    RunCmd( cmd, ui, argc, argv );

    // 
    // Save the specdef for this command...
    //
    if( ui->LastSpecDef().Length() )
	specDict.SetVar( cmd, ui->LastSpecDef() );

    if( P4PERL_DEBUG_CMDS )
	PerlIO_stdoutf( "[P4]: Completed: 'p4 %s'\n", cmdstr.Text() );

    return GetOutput();
}

//
// RunCmd is a private function to work around an obscure protocol
// bug in 2000.[12] servers. Running a "p4 -Ztag client -o" messes up the
// protocol so if they're running this command then we disconnect and
// reconnect to refresh it. For efficiency, we only do this if the 
// server2 protocol is either 9 or 10 as other versions aren't affected.
//
void
PerlClientApi::RunCmd( const char *cmd, ClientUser *ui, int argc, char * const *argv )
{
    // If maxresults or maxscanrows is set, enforce them now
    if( maxResults  )	client->SetVar( "maxResults",  maxResults  );
    if( maxScanRows )	client->SetVar( "maxScanRows", maxScanRows );
    if( maxLockTime )	client->SetVar( "maxLockTime", maxLockTime );
    if( tagged      )	client->SetVar( "tag", "" );

    client->SetProg( prog.Text() );
    if( version.Length() ) 
	client->SetVersion( version.Text() );

    client->SetArgv( argc, argv );
    client->Run( cmd, ui );

    // Have to request server2 protocol *after* a command has been run. 

    StrPtr *s = 0;
    if ( ! server2 )
    {
	s = client->GetProtocol( "server2" );
	if ( s )
	    server2 = s->Atoi();
    }

    if( s = client->GetProtocol( P4Tag::v_nocase ) )
    	caseSensitive = 0;

    if ( IsTagged() && StrRef( cmd ) == "client" && 
	 server2 >= 9    && server2 <= 10  )
    {
	if ( argc && ( StrRef( argv[ 0 ] ) == "-o" ) )
	{
	    if ( P4PERL_DEBUG_CMDS )
		PerlIO_stdoutf( "[P4]: Resetting connection to avoid obscure 2000.[12] protocol bug\n" );

	    Error e;
	    client->Final( &e );
	    client->Init( &e );

	    // Pass any errors down to the UI, so they'll get picked up.
	    if ( e.Test() ) 
		ui->HandleError( &e );
	}
    }
}

//
// Convert a spec in string form into a hash and return a reference to that
// hash.
//
SV *
PerlClientApi::ParseSpec( const char *type, const char *form )
{
    if( P4PERL_DEBUG_FLOW )
	PerlIO_stdoutf( "[P4]: Parsing a %s form\n", type );
    
    Error e;
    SV *spec = specMgr->StringToSpec( type, form, &e );
    if( e.Test() )
    {
	ui->HandleError( &e );
	return 0;
    }

    return spec;

}

//
// Convert a spec in hash form into its string representation
//
SV *
PerlClientApi::FormatSpec( const char *type, HV *hash )
{
    if( P4PERL_DEBUG_FLOW )
	PerlIO_stdoutf( "[P4]: Formatting a %s form\n", type );

    // Got a specdef so now we can attempt to convert. 
    StrBuf	buf;
    Error	e;
    specMgr->SpecToString( type, hash, buf, &e );
    if( e.Test() )
    {
	StrBuf m;
	m = "P4::FormatSpec(): Error converting hash to a string.";
	warn( "%s", m.Text() );
	e.Fmt( m, EF_PLAIN );
	warn( "%s", m.Text() );
	return &PL_sv_undef;
    }
    
    return newSVpv( buf.Text(), buf.Length() );
}