harness.pir

#!parrot
# Copyright (C) 2010, Parrot Foundation.

.sub 'main' :main
    .param pmc argv
    $S0  = shift argv
    .local int argc
    argc = elements argv
    if argc > 0 goto L1
    help()
    end
  L1:
    .local pmc opts
    opts = _parse_opts(argv)
    $I0 = exists opts['help']
    unless $I0 goto L2
    help()
    end
  L2:
    .tailcall do(opts, argv)
.end

.sub 'help' :anon
    say <<"HELP"
parrot t/harness.pir [options] [testfiles]
    --core-tests
    --runcore-tests
    --code-tests
    --archive  ... create a TAP archive of the test run
    --send-to-smolder ... send the TAP archive to the Parrot Smolder server
HELP
.end

.sub '_parse_opts' :anon
    .param pmc argv
    load_bytecode 'Getopt/Obj.pbc'
    $P0 = new ['Getopt';'Obj']
    $P0.'notOptStop'(1)
    push $P0, 'gc-debug'
    push $P0, 'core-tests'
    push $P0, 'runcore-tests'
    push $P0, 'code-tests'
    push $P0, 'run-exec'
    push $P0, 'archive'
    push $P0, 'send-to-smolder'
    push $P0, 'help|h'
    $P1 = $P0.'get_options'(argv)
    .return ($P1)
.end

.sub 'do' :anon
    .param pmc opts
    .param pmc files
    set_test_prog_args(opts)
    load_bytecode 'TAP/Harness.pbc'
    .local pmc options, env, harness, aggregate
    options = new 'Hash'
    env = new 'Env'
    $I0 = exists env['HARNESS_VERBOSE']
    unless $I0 goto L1
    $S0 = env['HARNESS_VERBOSE']
    options['verbosity'] = $S0
  L1:
    $I0 = exists opts['archive']
    if $I0 goto L2
    harness = new ['TAP';'Harness']
    options['directives'] = 1
    goto L3
  L2:
    harness = new ['TAP';'Harness';'Archive']
    harness.'archive'('t/archive/parrot_test_run.tar.gz')
    options['merge'] = 1
    .local pmc env_data
    env_data = collect_test_environment_data()
    harness.'extra_props'(env_data)
    $P0 = split ' ', 'myconfig config_lib.pir'
    harness.'extra_files'($P0)
  L3:
    harness.'process_args'(options)
    $P0 = _get_tests(opts, files)
    aggregate = harness.'runtests'($P0)
    $I0 = exists opts['send-to-smolder']
    unless $I0 goto L4
    .tailcall send_archive_to_smolder(env_data)
  L4:
    $I0 = aggregate.'all_passed'()
    $I0 = not $I0
    exit $I0
.end

.sub 'set_test_prog_args' :anon
    .param pmc opts
    $S0 = ''
    $I0 = exists opts['gc-debug']
    unless $I0 goto L1
    $S0 .= ' --gc-debug'
  L1:
    $I0 = exists opts['run-exec']
    unless $I0 goto L2
    $S0 .= ' --run-exec'
  L2:
    $S0 = substr $S0, 1
    $P0 = new 'Env'
    $P0['TEST_PROG_ARGS'] = $S0
.end

.sub '_get_tests' :anon
    .param pmc opts
    .param pmc files
    .local int nb
    $I0 = opts['code-tests']
    unless $I0 goto L1
    .const string developing_tests = 't/codingstd/*.t'
    files = glob(developing_tests)
    goto L2
  L1:
    nb = elements files
    unless nb == 0 goto L2
    files = _get_common_tests(opts)
  L2:
    nb = elements files
    # currently, FixedStringArray hasn't the method sort.
    # see GH #384
    $P0 = new 'FixedPMCArray'
    set $P0, nb
    $I0 = 0
    $P1 = iter files
  L3:
    unless $P1 goto L4
    $S0 = shift $P1
    $P2 = split "\\", $S0
    $S0 = join "/", $P2
    $P2 = box $S0
    $P0[$I0] = $P2
    inc $I0
    goto L3
  L4:
    $P0.'sort'()
    .return ($P0)
.end

.sub '_get_common_tests' :anon
    .param pmc opts
    .const string runcore_tests = <<'TEST'
t/compilers/imcc/*/*.t
t/op/*.t
t/pmc/*.t
t/oo/*.t
t/pir/*.t
t/native_pbc/*.t
TEST
    .const string core_tests = <<'TEST'
t/src/*.t
t/src/embed/*.t
t/run/*.t
t/perl/*.t
TEST
    .const string library_tests = <<'TEST'
t/compilers/pct/*.t
t/compilers/pge/*.t
t/compilers/pge/p5regex/*.t
t/compilers/pge/perl6regex/*.t
t/compilers/tge/*.t
t/compilers/opsc/*.t
t/compilers/data_json/*.t
ext/nqp-rx/t/nqp/*.t
t/dynoplibs/*.t
t/dynpmc/*.t
t/library/*.t
t/ext/winxed/*.t
t/tools/*.t
t/profiling/*.t
TEST
    .const string configure_tests = <<'TEST'
t/configure/*.t
t/steps/*.t
t/postconfigure/*.t
TEST
    $S0 = runcore_tests
    $I0 = exists opts['runcore-tests']
    if $I0 goto L1
    $S0 .= core_tests
    $I0 = exists opts['core-tests']
    if $I0 goto L1
    $S0 .= library_tests
    $S0 .= configure_tests
  L1:
    $P0 = split "\n", $S0
    $S0 = join ' ', $P0
    $P0 = glob($S0)
    .return ($P0)
.end

.include 'iglobals.pasm'

.sub 'collect_test_environment_data' :anon
    .local pmc config, env
    $P0 = getinterp
    config = $P0[.IGLOBALS_CONFIG_HASH]
    env = new 'Env'
    $P0 = new 'Hash'
    .local string arch
    arch = config['cpuarch']
    $P0['Architecture'] = arch
    $S0 = _get_compiler_version(config)
    $P0['Compiler'] = $S0
    .local string devel
    devel = config['DEVEL']
    $P0['DEVEL'] = devel
    .local string optimize
    optimize = 'none'
    $I0 = exists config['optimize']
    unless $I0 goto L1
    optimize = config['optimize']
  L1:
    $P0['Optimize'] = optimize

    $I0 = exists config['configure_args']
    unless $I0 goto L2
    $S0 = config['configure_args']
    $P0['Configure args'] = $S0
  L2:
    .local string osname
    osname = config['osname']
    $P0['Platform'] = osname
    .local string version
    version = config['VERSION']
    $P0['Version'] = version
    .local string submitter
    submitter = _get_submitter(config, env)
    $P0['Submitter'] = submitter
    $I0 = exists config['sha1']
    unless $I0 goto L3
    .local string sha1
    sha1 = config['sha1']
    $P0['Git sha1'] = sha1
  L3:
    _add_git_info($P0)
    .return ($P0)
.end

.sub '_get_compiler_version' :anon
    .param pmc config
    $S0 = config['cc']
    $I0 = index $S0, 'gcc'
    unless $I0 >= 0 goto L1
    $I0 = exists config['gccversion']
    unless $I0 goto L1
    $S0 .= ' '
    $S1 = config['gccversion']
    $S0 .= $S1
    .return ($S0)
  L1:
    $I0 = index $S0, 'cl'
    unless $I0 >= 0 goto L2
    $I0 = exists config['msvcversion']
    unless $I0 goto L2
    $S0 .= ' '
    $S1 = config['msvcversion']
    $S0 .= $S1
    .return ($S0)
  L2:
    $I0 = exists config['gccversion']
    unless $I0 goto L3
    $S0 .= ' (gcc '
    $S1 = config['gccversion']
    $S0 .= $S1
    $S0 .= ')'
    .return ($S0)
  L3:
    $I0 = exists config['msvcversion']
    unless $I0 goto L4
    $S0 .= ' (msvc '
    $S1 = config['msvcversion']
    $S0 .= $S1
    $S0 .= ')'
    .return ($S0)
  L4:
    .return ($S0)
.end

.sub '_get_submitter' :anon
    .param pmc config
    .param pmc env
    $I0 = exists env['SMOLDER_SUBMITTER']
    unless $I0 goto L1
    $S0 = env['SMOLDER_SUBMITTER']
    .return ($S0)
  L1:
    .local string me
    $I0 = exists config['win32']
    unless $I0 goto L2
    me = env['USERNAME']
    goto L3
  L2:
    me = env['LOGNAME']
  L3:
    $S0 = me . '@unknown'
    .return ($S0)
.end

.include 'cclass.pasm'

.sub '_add_git_info' :anon
    .param pmc hash
    $I0 = file_exists('.git')
    unless $I0 goto L1
    $P0 = new 'FileHandle'
    $P0.'open'('git branch', 'pr')
    $S0 = $P0.'readall'()
    $P0.'close'()
    $I0 = length $S0
    $I1 = index $S0, '*'
    unless $I1 >= 0 goto L2
    $I1 += 1
    $I1 = find_not_cclass .CCLASS_WHITESPACE, $S0, $I1, $I0
    $I2 = find_cclass .CCLASS_WHITESPACE, $S0, $I1, $I0
    $I3 = $I2 - $I1
    $S1 = substr $S0, $I1, $I3
    hash['Branch'] = $S1
  L2:
    $P0.'open'('git status', 'pr')
    $P1 = new 'ResizableStringArray'
  L3:
    $S0 = $P0.'readline'()
    if $S0 == '' goto L4
    $I1 = index $S0, 'modified:'
    unless $I1 > 0 goto L3
    $I1 += 9
    $S0 = chomp($S0)
    $I0 = length $S0
    $I1 = find_not_cclass .CCLASS_WHITESPACE, $S0, $I1, $I0
    $S0 = substr $S0, $I1
    push $P1, $S0
    goto L3
  L4:
    $P0.'close'()
    $I0 = elements $P1
    unless $I0 != 0 goto L1
    $S0 = hash['DEVEL']
    $S0 .= ' '
    $S1 = $I0
    $S0 .= $S1
    $S0 .= ' mods'
    hash['DEVEL'] = $S0
    $S0 = join ' ', $P1
    hash['Modifications'] = $S0
  L1:
    .return (hash)
.end

.sub 'send_archive_to_smolder' :anon
    .param pmc env_data
    .local pmc config
    $P0 = getinterp
    config = $P0[.IGLOBALS_CONFIG_HASH]
    .local pmc contents
    contents = new 'ResizablePMCArray' # by couple
    push contents, 'Architecture'
    $S0 = config['cpuarch']
    push contents, $S0
    push contents, 'Platform'
    $S0 = config['osname']
    push contents, $S0
    $I0 = exists config['git_describe']
    unless $I0 goto L0
    push contents, 'revision'
    $S0 = config['git_describe']
    push contents, $S0
  L0:
    push contents, 'tags'
    $S0 = _get_tags(env_data)
    push contents, $S0
    push contents, 'username'
    push contents, 'parrot-autobot'
    push contents, 'password'
    push contents, 'qa_rocks'
    push contents, 'comments'
    push contents, "EXPERIMENTAL t/harness.pir with LWP.pir"
    push contents, 'report_file'
    $P0 = new 'FixedStringArray'
    set $P0, 1
    $P0[0] = 't/archive/parrot_test_run.tar.gz'
    push contents, $P0
    load_bytecode 'LWP/UserAgent.pir'
    .const string url = 'http://smolder.parrot.org/app/projects/process_add_report/1'
    .local pmc ua, response
    ua = new ['LWP';'UserAgent']
    ua.'env_proxy'()
    ua.'show_progress'(1)
    response = ua.'post'(url, contents :flat, 'form-data' :named('Content-Type'), 'close' :named('Connection'))
    $I0 = response.'code'()
    unless $I0 == 302 goto L1
    $S0 = response.'content'()
    say $S0
  L1:
.end

.sub '_get_tags' :anon
    .param pmc env_data
    $P0 = split ' ', 'Architecture Compiler Platform Version'
    $P1 = new 'ResizableStringArray'
  L1:
    unless $P0 goto L2
    $S0 = shift $P0
    $S1 = env_data[$S0]
    push $P1, $S1
    goto L1
  L2:
    $S0 = join ', ', $P1
    .return ($S0)
.end


# Local Variables:
#   mode: pir
#   fill-column: 100
# End:
# vim: expandtab shiftwidth=4 ft=pir: